~ syntax stuff
This commit is contained in:
parent
c1389c3906
commit
09a76fa8c1
1 changed files with 31 additions and 24 deletions
|
|
@ -1,5 +1,4 @@
|
|||
open Rresult
|
||||
open Lwt.Infix
|
||||
open Cmdliner
|
||||
|
||||
let port =
|
||||
|
|
@ -148,38 +147,45 @@ struct
|
|||
end
|
||||
|
||||
let tls certificate_ro key_ro =
|
||||
let ( >>= ) = Lwt_result.bind in
|
||||
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
|
||||
>>= fun keys ->
|
||||
in
|
||||
let keys = List.filter (fun (_, t) -> t = `Value) keys in
|
||||
let*? certificates =
|
||||
Certificates_ro.list certificate_ro Mirage_kv.Key.empty
|
||||
|> map_err_to_string Certificates_ro.pp_error
|
||||
>>= fun 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*? data =
|
||||
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)
|
||||
in
|
||||
Lwt_list.fold_left_s fold (Ok []) certificates >>= fun certificates ->
|
||||
let*? certificates =
|
||||
Lwt.return (X509.Certificate.decode_pem_multiple data)
|
||||
in
|
||||
let+? acc = Lwt.return acc in
|
||||
(name, certificates) :: acc
|
||||
in
|
||||
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
|
||||
Lwt_list.fold_left_s fold (Ok []) keys >>= fun keys ->
|
||||
let*? key = Lwt.return (X509.Private_key.decode_pem data) in
|
||||
let+? acc = Lwt.return acc in
|
||||
(name, key) :: acc
|
||||
in
|
||||
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,9 @@ 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 http_1_1_request_handler ~ctx ~authenticator flow _edn =
|
||||
let module R = (val Mimic.repr HTTP_server.tcp_protocol) in
|
||||
|
|
@ -223,6 +229,7 @@ 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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue