~ syntax stuff
This commit is contained in:
parent
c1389c3906
commit
c9ca55bf5a
1 changed files with 45 additions and 37 deletions
|
|
@ -1,5 +1,4 @@
|
||||||
open Rresult
|
open Rresult
|
||||||
open Lwt.Infix
|
|
||||||
open Cmdliner
|
open Cmdliner
|
||||||
|
|
||||||
let port =
|
let port =
|
||||||
|
|
@ -57,9 +56,10 @@ module Make
|
||||||
(Connect : Connect.S)
|
(Connect : Connect.S)
|
||||||
(HTTP_server : Paf_mirage.S) =
|
(HTTP_server : Paf_mirage.S) =
|
||||||
struct
|
struct
|
||||||
module Assets = struct
|
|
||||||
let ( let*? ) = Lwt_result.bind
|
let ( let*? ) = Lwt_result.bind
|
||||||
let ( let+? ) x f = Lwt_result.map f x
|
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 map_err_to_string = map_err_to_string Assets_ro.pp_error
|
||||||
|
|
||||||
let get_subdirs ro k =
|
let get_subdirs ro k =
|
||||||
|
|
@ -148,38 +148,43 @@ struct
|
||||||
end
|
end
|
||||||
|
|
||||||
let tls certificate_ro key_ro =
|
let tls certificate_ro key_ro =
|
||||||
let ( >>= ) = Lwt_result.bind in
|
let*? keys =
|
||||||
Keys_ro.list key_ro Mirage_kv.Key.empty
|
Keys_ro.list key_ro Mirage_kv.Key.empty
|
||||||
|> map_err_to_string Keys_ro.pp_error
|
|> map_err_to_string Keys_ro.pp_error
|
||||||
>>= fun keys ->
|
in
|
||||||
let keys = List.filter (fun (_, t) -> t = `Value) keys in
|
let keys = List.filter (fun (_, t) -> t = `Value) keys in
|
||||||
|
let*? certificates =
|
||||||
Certificates_ro.list certificate_ro Mirage_kv.Key.empty
|
Certificates_ro.list certificate_ro Mirage_kv.Key.empty
|
||||||
|> map_err_to_string Certificates_ro.pp_error
|
|> map_err_to_string Certificates_ro.pp_error
|
||||||
>>= fun certificates ->
|
in
|
||||||
let certificates = List.filter (fun (_, t) -> t = `Value) certificates in
|
let certificates = List.filter (fun (_, t) -> t = `Value) certificates in
|
||||||
let fold acc (name, _) =
|
let fold acc (name, _) =
|
||||||
match Mirage_kv.Key.basename name with
|
match Mirage_kv.Key.basename name with
|
||||||
| ".gitkeep" -> Lwt.return acc
|
| ".gitkeep" -> Lwt.return acc
|
||||||
| _ ->
|
| _ ->
|
||||||
|
let*? data =
|
||||||
Certificates_ro.get certificate_ro name
|
Certificates_ro.get certificate_ro name
|
||||||
|> map_err_to_string Certificates_ro.pp_error
|
|> 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
|
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, _) =
|
let fold acc (name, _) =
|
||||||
match Mirage_kv.Key.basename name with
|
match Mirage_kv.Key.basename name with
|
||||||
| ".gitkeep" -> Lwt.return acc
|
| ".gitkeep" -> Lwt.return acc
|
||||||
| _ ->
|
| _ ->
|
||||||
Keys_ro.get key_ro name
|
let*? data =
|
||||||
|> map_err_to_string Keys_ro.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)
|
|
||||||
in
|
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
|
let tbl = Hashtbl.create 0x10 in
|
||||||
List.iter
|
List.iter
|
||||||
(fun (name, certificates) ->
|
(fun (name, certificates) ->
|
||||||
|
|
@ -188,9 +193,9 @@ struct
|
||||||
| None -> ())
|
| None -> ())
|
||||||
certificates;
|
certificates;
|
||||||
match Hashtbl.fold (fun _ certchain acc -> certchain :: acc) tbl [] with
|
match Hashtbl.fold (fun _ certchain acc -> certchain :: acc) tbl [] with
|
||||||
| [] -> Lwt.return_ok `None
|
| [] -> `None
|
||||||
| [ certchain ] -> Lwt.return_ok (`Single certchain)
|
| [ certchain ] -> `Single certchain
|
||||||
| certchains -> Lwt.return_ok (`Multiple certchains)
|
| certchains -> `Multiple certchains
|
||||||
|
|
||||||
let http_1_1_request_handler ~ctx ~authenticator flow _edn =
|
let http_1_1_request_handler ~ctx ~authenticator flow _edn =
|
||||||
let module R = (val Mimic.repr HTTP_server.tcp_protocol) in
|
let module R = (val Mimic.repr HTTP_server.tcp_protocol) in
|
||||||
|
|
@ -230,10 +235,12 @@ struct
|
||||||
HTTP_server.http_service ~error_handler:Server.http_1_1_error_handler
|
HTTP_server.http_service ~error_handler:Server.http_1_1_error_handler
|
||||||
(http_1_1_request_handler ~ctx ~authenticator)
|
(http_1_1_request_handler ~ctx ~authenticator)
|
||||||
in
|
in
|
||||||
HTTP_server.init ~port:tls_port tcpv4v6 >|= Paf.serve alpn_service
|
let open Lwt.Syntax in
|
||||||
>>= fun (`Initialized th0) ->
|
let* server = HTTP_server.init ~port:tls_port tcpv4v6 in
|
||||||
Paf.serve http_1_1_service http_server |> fun (`Initialized th1) ->
|
let (`Initialized th0) = Paf.serve alpn_service server in
|
||||||
Lwt.both th0 th1 >>= fun ((), ()) -> Lwt.return_unit
|
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 run ~ctx ~authenticator http_server =
|
||||||
let http_1_1_service =
|
let http_1_1_service =
|
||||||
|
|
@ -243,23 +250,24 @@ struct
|
||||||
Paf.serve http_1_1_service http_server |> fun (`Initialized th) -> th
|
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 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
|
let authenticator = Connect.authenticator in
|
||||||
Assets.assets assets_ro >>= fun res ->
|
let* assets_res = Assets.assets assets_ro in
|
||||||
match res with
|
match assets_res with
|
||||||
| Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m
|
| Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m
|
||||||
| Ok (terms, _privacy) -> (
|
| Ok (_terms, _privacy) -> (
|
||||||
|
(*
|
||||||
let etag, lang_l, ext_l = terms in
|
let etag, lang_l, ext_l = terms in
|
||||||
Fmt.pr "ETAG: %s@\nlanguages: %a@\nextensions: %a@." etag
|
Fmt.pr "ETAG: %s@\nlanguages: %a@\nextensions: %a@." etag
|
||||||
(Fmt.list ~sep:(Fmt.any ", ") Fmt.string)
|
(Fmt.list ~sep:(Fmt.any ", ") Fmt.string)
|
||||||
lang_l
|
lang_l
|
||||||
(Fmt.list ~sep:(Fmt.any ", ") Fmt.string)
|
(Fmt.list ~sep:(Fmt.any ", ") Fmt.string)
|
||||||
ext_l;
|
ext_l; *)
|
||||||
tls certificate_ro key_ro >>= fun tls ->
|
let* tls_res = tls certificate_ro key_ro in
|
||||||
match use_tls () with
|
match use_tls () with
|
||||||
| false -> run ~ctx ~authenticator http_server
|
| false -> run ~ctx ~authenticator http_server
|
||||||
| true -> (
|
| true -> (
|
||||||
match tls with
|
match tls_res with
|
||||||
| Error (`Msg m) ->
|
| Error (`Msg m) ->
|
||||||
Fmt.failwith
|
Fmt.failwith
|
||||||
"A TLS server requires, at least, one certificate and one \
|
"A TLS server requires, at least, one certificate and one \
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue