This commit is contained in:
parent
9390ece117
commit
0f9aa82c7a
1 changed files with 27 additions and 34 deletions
|
|
@ -36,16 +36,14 @@ module Make
|
|||
(Connect : Connect.S)
|
||||
(HTTP_server : Paf_mirage.S) =
|
||||
struct
|
||||
let tls key_ro certificate_ro =
|
||||
let open Lwt_result.Infix in
|
||||
Lwt.Infix.(
|
||||
let tls certificate_ro key_ro =
|
||||
let ( >>= ) = Lwt_result.bind in
|
||||
Key.list key_ro Mirage_kv.Key.empty
|
||||
>|= R.reword_error (R.msgf "%a" Key.pp_error))
|
||||
|> Lwt.map (R.reword_error (R.msgf "%a" Key.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))
|
||||
|> Lwt.map (R.reword_error (R.msgf "%a" Certificate.pp_error))
|
||||
>>= fun certificates ->
|
||||
let certificates, _ =
|
||||
List.partition (fun (_, t) -> t = `Value) certificates
|
||||
|
|
@ -54,10 +52,8 @@ struct
|
|||
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))
|
||||
|> Lwt.map (R.reword_error (R.msgf "%a" Certificate.pp_error))
|
||||
>>= (Lwt.return <.> X509.Certificate.decode_pem_multiple)
|
||||
>>= fun certificates ->
|
||||
Lwt.return acc >>= fun acc ->
|
||||
|
|
@ -68,9 +64,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))
|
||||
Key.get key_ro name
|
||||
|> Lwt.map (R.reword_error (R.msgf "%a" Key.pp_error))
|
||||
>>= (Lwt.return <.> X509.Private_key.decode_pem)
|
||||
>>= fun key ->
|
||||
Lwt.return acc >>= fun acc -> Lwt.return_ok ((name, key) :: acc)
|
||||
|
|
@ -141,23 +136,21 @@ struct
|
|||
let start 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 =
|
||||
tls certificate_ro key_ro >>= fun tls ->
|
||||
match use_tls () with
|
||||
| false -> run ~ctx ~authenticator http_server
|
||||
| true -> (
|
||||
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
|
||||
| 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 -> tls
|
||||
in
|
||||
run_with_tls ~ctx ~authenticator ~tls http_server (tls_port ()) tcpv4v6
|
||||
else run ~ctx ~authenticator http_server
|
||||
| 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