This commit is contained in:
parent
09a76fa8c1
commit
70804cc387
1 changed files with 17 additions and 16 deletions
|
|
@ -56,9 +56,10 @@ module Make
|
|||
(Connect : Connect.S)
|
||||
(HTTP_server : Paf_mirage.S) =
|
||||
struct
|
||||
module Assets = struct
|
||||
let ( let*? ) = Lwt_result.bind
|
||||
let ( let+? ) x f = Lwt_result.map f x
|
||||
|
||||
module Assets = struct
|
||||
let map_err_to_string = map_err_to_string Assets_ro.pp_error
|
||||
|
||||
let get_subdirs ro k =
|
||||
|
|
@ -147,8 +148,6 @@ struct
|
|||
end
|
||||
|
||||
let tls certificate_ro key_ro =
|
||||
let ( let*? ) = Lwt_result.bind in
|
||||
let ( let+? ) x f = Lwt_result.map f x in
|
||||
let*? keys =
|
||||
Keys_ro.list key_ro Mirage_kv.Key.empty
|
||||
|> map_err_to_string Keys_ro.pp_error
|
||||
|
|
@ -229,7 +228,6 @@ struct
|
|||
}
|
||||
|
||||
let run_with_tls ~ctx ~authenticator ~tls http_server tls_port tcpv4v6 =
|
||||
let open Lwt.Infix in
|
||||
let alpn_service =
|
||||
HTTP_server.alpn_service ~tls (alpn_handler ~ctx ~authenticator)
|
||||
in
|
||||
|
|
@ -237,10 +235,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 =
|
||||
|
|
@ -250,23 +250,24 @@ 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) -> (
|
||||
| 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 ->
|
||||
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