~ syntax stuff
This commit is contained in:
parent
774d55ebb1
commit
f4eb197093
4 changed files with 131 additions and 102 deletions
|
|
@ -1,6 +1,6 @@
|
|||
open Rresult
|
||||
open Lwt.Infix
|
||||
open Cmdliner
|
||||
open Syntax
|
||||
|
||||
let port =
|
||||
let doc = Arg.info ~doc:"Port of HTTP service." [ "p"; "port" ] in
|
||||
|
|
@ -26,29 +26,9 @@ let alpn =
|
|||
Mirage_runtime.register_arg
|
||||
Arg.(value & opt_all (enum (List.map (fun v -> (v, v)) alpns)) alpns doc)
|
||||
|
||||
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
|
||||
(Assets_ro : Mirage_kv.RO)
|
||||
(Certificates_ro : Mirage_kv.RO)
|
||||
|
|
@ -58,8 +38,6 @@ module Make
|
|||
(HTTP_server : Paf_mirage.S) =
|
||||
struct
|
||||
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 =
|
||||
|
|
@ -125,61 +103,89 @@ struct
|
|||
(Fmt.list Fmt.string) l
|
||||
in
|
||||
let* ext_l =
|
||||
let ll =
|
||||
let* hd, tl =
|
||||
l
|
||||
|> List.map (fun (_, _, v) -> v)
|
||||
|> List.map (List.sort String.compare)
|
||||
|> function
|
||||
| [] ->
|
||||
Fmt.error_msg "directory `%s` is empty"
|
||||
(Mirage_kv.Key.to_string dir)
|
||||
| hd :: tl -> Ok (hd, tl)
|
||||
in
|
||||
match List.sort_uniq Stdlib.compare ll with
|
||||
| [ l ] -> Ok l
|
||||
| [] -> assert false
|
||||
| _ll ->
|
||||
match List.for_all (( = ) hd) tl with
|
||||
| false ->
|
||||
Fmt.error_msg
|
||||
"directory `%s` does not has the same set of file extensions for \
|
||||
each language"
|
||||
(Mirage_kv.Key.to_string dir)
|
||||
| true -> Ok hd
|
||||
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)
|
||||
let*? terms_etag, terms_lang_l, terms_ext_l = get ro "terms" in
|
||||
let*? privacy_etag, privacy_lang_l, privacy_ext_l = get ro "privacy" in
|
||||
Lwt.return
|
||||
@@
|
||||
let open Result.Syntax in
|
||||
let* lang_l =
|
||||
match terms_lang_l = privacy_lang_l with
|
||||
| false ->
|
||||
Fmt.error_msg
|
||||
"terms and privacy directories does not support the same set of \
|
||||
languages"
|
||||
| true -> Ok terms_lang_l
|
||||
in
|
||||
let ext_l =
|
||||
match terms_ext_l = privacy_ext_l with
|
||||
| false ->
|
||||
Fmt.error_msg
|
||||
"terms and privacy directories does not support the same set of \
|
||||
mimetype"
|
||||
| true -> Ok terms_ext_l
|
||||
in
|
||||
Ok (terms_etag, privacy_etag, lang_l, ext_l)
|
||||
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 =
|
||||
Keys_ro.list key_ro Mirage_kv.Key.empty
|
||||
|> map_err_to_string Keys_ro.pp_error
|
||||
in
|
||||
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 =
|
||||
Certificates_ro.list certificate_ro Mirage_kv.Key.empty
|
||||
|> map_err_to_string Certificates_ro.pp_error
|
||||
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
|
||||
| _ ->
|
||||
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 ->
|
||||
Lwt.return_ok ((name, certificates) :: acc)
|
||||
let*? data =
|
||||
Certificates_ro.get certificate_ro name
|
||||
|> map_err_to_string Certificates_ro.pp_error
|
||||
in
|
||||
let*? certificates =
|
||||
Lwt.return (X509.Certificate.decode_pem_multiple data)
|
||||
in
|
||||
let+? acc = Lwt.return acc in
|
||||
(name, certificates) :: acc
|
||||
in
|
||||
Lwt_list.fold_left_s fold (Ok []) certificates >>= fun certificates ->
|
||||
let*? certificates = Lwt_list.fold_left_s fold (Ok []) certificates in
|
||||
let fold acc (name, _) =
|
||||
match Mirage_kv.Key.basename name with
|
||||
| ".gitkeep" -> Lwt.return acc
|
||||
| _ ->
|
||||
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)
|
||||
let*? data =
|
||||
Keys_ro.get key_ro name |> map_err_to_string Keys_ro.pp_error
|
||||
in
|
||||
let*? key = Lwt.return (X509.Private_key.decode_pem data) in
|
||||
let+? acc = Lwt.return acc in
|
||||
(name, key) :: acc
|
||||
in
|
||||
Lwt_list.fold_left_s fold (Ok []) keys >>= fun keys ->
|
||||
let+? keys = Lwt_list.fold_left_s fold (Ok []) keys in
|
||||
let tbl = Hashtbl.create 0x10 in
|
||||
List.iter
|
||||
(fun (name, certificates) ->
|
||||
|
|
@ -188,9 +194,11 @@ struct
|
|||
| None -> ())
|
||||
certificates;
|
||||
match Hashtbl.fold (fun _ certchain acc -> certchain :: acc) tbl [] with
|
||||
| [] -> Lwt.return_ok `None
|
||||
| [ certchain ] -> Lwt.return_ok (`Single certchain)
|
||||
| certchains -> Lwt.return_ok (`Multiple certchains)
|
||||
| [] -> `None
|
||||
| [ certchain ] -> `Single certchain
|
||||
| certchains -> `Multiple certchains
|
||||
|
||||
let always x _ = x
|
||||
|
||||
let http_1_1_request_handler ~ctx ~authenticator flow _edn =
|
||||
let module R = (val Mimic.repr HTTP_server.tcp_protocol) in
|
||||
|
|
@ -230,10 +238,12 @@ struct
|
|||
HTTP_server.http_service ~error_handler:Server.http_1_1_error_handler
|
||||
(http_1_1_request_handler ~ctx ~authenticator)
|
||||
in
|
||||
HTTP_server.init ~port:tls_port tcpv4v6 >|= Paf.serve alpn_service
|
||||
>>= fun (`Initialized th0) ->
|
||||
Paf.serve http_1_1_service http_server |> fun (`Initialized th1) ->
|
||||
Lwt.both th0 th1 >>= fun ((), ()) -> Lwt.return_unit
|
||||
let open Lwt.Syntax in
|
||||
let* server = HTTP_server.init ~port:tls_port tcpv4v6 in
|
||||
let (`Initialized th0) = Paf.serve alpn_service server in
|
||||
let (`Initialized th1) = Paf.serve http_1_1_service http_server in
|
||||
let+ (), () = Lwt.both th0 th1 in
|
||||
()
|
||||
|
||||
let run ~ctx ~authenticator http_server =
|
||||
let http_1_1_service =
|
||||
|
|
@ -243,23 +253,17 @@ struct
|
|||
Paf.serve http_1_1_service http_server |> fun (`Initialized th) -> th
|
||||
|
||||
let start assets_ro certificate_ro key_ro tcpv4v6 ctx http_server =
|
||||
let open Lwt.Infix in
|
||||
let open Lwt.Syntax in
|
||||
let authenticator = Connect.authenticator in
|
||||
Assets.assets assets_ro >>= fun res ->
|
||||
match res with
|
||||
let* assets_res = Assets.assets assets_ro in
|
||||
match assets_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 ->
|
||||
| Ok (_terms_etag, _privacy_etag, _lang_l, _ext_l) -> (
|
||||
let* tls_res = tls certificate_ro key_ro in
|
||||
match use_tls () with
|
||||
| false -> run ~ctx ~authenticator http_server
|
||||
| true -> (
|
||||
match tls with
|
||||
match tls_res with
|
||||
| Error (`Msg m) ->
|
||||
Fmt.failwith
|
||||
"A TLS server requires, at least, one certificate and one \
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue