From 367e1226d0964baf61fde8f561d79ee2c458c437 Mon Sep 17 00:00:00 2001 From: ArtichautCosmique Date: Wed, 21 Dec 2022 00:13:58 +0100 Subject: [PATCH] Client certificate. (#24) Co-authored-by: Tim-ats-d --- .gitignore | 4 ++++ examples/client_cert.ml | 22 ++++++++++++++++++++++ examples/dune | 11 ++++++++++- mehari-eio/server_impl.ml | 16 +++++++++++++--- mehari-mirage/server_impl.ml | 10 +++++++++- mehari/dune | 3 ++- mehari/mehari.ml | 1 + mehari/mehari.mli | 4 ++++ mehari/request.ml | 6 ++++-- 9 files changed, 69 insertions(+), 8 deletions(-) create mode 100644 examples/client_cert.ml diff --git a/.gitignore b/.gitignore index 63f385b..0418cb8 100644 --- a/.gitignore +++ b/.gitignore @@ -31,3 +31,7 @@ _opam/ # Certificates *.pem + +# Sublime Text +*.sublime-project +*.sublime-workspace diff --git a/examples/client_cert.ml b/examples/client_cert.ml new file mode 100644 index 0000000..a0d06e3 --- /dev/null +++ b/examples/client_cert.ml @@ -0,0 +1,22 @@ +let router = + Mehari_eio.router + [ + Mehari_eio.route "/" (fun req -> + match Mehari.client_cert req with + | [] -> Mehari.(response client_cert_req) "Certificate plz" + | hd :: _ -> + X509.Certificate.encode_pem hd + |> Cstruct.to_string + |> Printf.sprintf "Client certificate ~nyoron\n%s" + |> Mehari.response_text); + ] + +let main ~net ~cwd = + Mehari_eio.run net + ~certchains:Eio.Path.[ (cwd / "cert.pem", cwd / "key.pem") ] + router + +let () = + Eio_main.run @@ fun env -> + Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () -> + main ~net:env#net ~cwd:env#cwd diff --git a/examples/dune b/examples/dune index 5b7f3fa..f9335cd 100644 --- a/examples/dune +++ b/examples/dune @@ -1,5 +1,14 @@ (executables - (names counter echo eio_backend hello guestbook log rate_limit stream) + (names + client_cert + counter + echo + eio_backend + hello + guestbook + log + rate_limit + stream) (libraries ipaddr eio_main diff --git a/mehari-eio/server_impl.ml b/mehari-eio/server_impl.ml index 3a89110..c7523d8 100644 --- a/mehari-eio/server_impl.ml +++ b/mehari-eio/server_impl.ml @@ -71,9 +71,14 @@ module Make (Logger : Mehari.Private.Logger_impl.S) : client_req reader |> Protocol.static_check_request ~port ~hostnames with | Ok uri -> + let client_cert = + match ep with + | Ok data -> Option.to_list data.Tls.Core.peer_certificate + | Error () -> assert false + in Mehari.Private.make_request (module Common.Addr) - ~uri ~addr ~port ~sni + ~uri ~addr ~port ~sni ~client_cert |> callback |> write_resp flow | Error err -> Protocol.to_response err |> write_resp flow with @@ -91,7 +96,11 @@ module Make (Logger : Mehari.Private.Logger_impl.S) : | _ -> invalid_arg "Mehari_eio.run" in let server = - Tls_eio.server_of_flow (Tls.Config.server ~certificates ()) flow + Tls_eio.server_of_flow + (Tls.Config.server ~certificates + ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) + ()) + flow in Tls_eio.epoch server |> handle_client ~addr ~port callback server @@ -106,8 +115,9 @@ module Make (Logger : Mehari.Private.Logger_impl.S) : | Tls_eio.Tls_failure f -> Log.warn (fun log -> log "Tls failure: %S" (Tls.Engine.string_of_failure f)) - | Eio.Exn.Io (Eio.Net.E (Connection_reset _), _) -> + (*| Eio.Exn.Io (Eio.Net.E (Connection_reset _), _) -> Log.warn (fun log -> log "Concurrent connections") + FIXME: Removed due to unavailability outside of Linux *) | exn -> raise exn in Eio.Switch.run (fun sw -> diff --git a/mehari-mirage/server_impl.ml b/mehari-mirage/server_impl.ml index e4ff850..96581fd 100644 --- a/mehari-mirage/server_impl.ml +++ b/mehari-mirage/server_impl.ml @@ -77,7 +77,15 @@ module Make (Stack : Tcpip.Stack.V4V6) (Logger : Private.Logger_impl.S) : | Ok data -> Option.map Domain_name.to_string data.Tls.Core.own_name | Error () -> assert false in - Private.make_request (module Ipaddr) ~addr ~port ~uri ~sni |> callback + let client_cert = + match ep with + | Ok data -> Option.to_list data.Tls.Core.peer_certificate + | Error () -> assert false + in + Private.make_request + (module Ipaddr) + ~addr ~port ~uri ~sni ~client_cert + |> callback in write_resp chan resp diff --git a/mehari/dune b/mehari/dune index f8c0f7b..ff091eb 100644 --- a/mehari/dune +++ b/mehari/dune @@ -8,4 +8,5 @@ magic-mime mirage-clock uri - zed)) + zed + x509)) diff --git a/mehari/mehari.ml b/mehari/mehari.ml index 190410f..03f9349 100644 --- a/mehari/mehari.ml +++ b/mehari/mehari.ml @@ -11,6 +11,7 @@ let ip = Request.ip let port = Request.port let sni = Request.sni let query = Request.query +let client_cert = Request.client_cert let param = Request.param let response = Response.response let response_body = Response.response_body diff --git a/mehari/mehari.mli b/mehari/mehari.mli index a5490fe..4838885 100644 --- a/mehari/mehari.mli +++ b/mehari/mehari.mli @@ -46,6 +46,9 @@ val sni : 'a request -> string option val query : 'a request -> string option (** User uri query. *) +val client_cert : 'a request -> X509.Certificate.t list +(** User client certificate. *) + val param : 'a request -> int -> string (** [param req n] retrieves the [n]-th path parameter of [req]. @raise Invalid_argument if [n] is not a positive integer or path does not @@ -256,6 +259,7 @@ module Private : sig addr:'addr -> port:int -> sni:string option -> + client_cert:X509.Certificate.t list -> 'addr request module Handler : sig diff --git a/mehari/request.ml b/mehari/request.ml index 8188945..95b9c61 100644 --- a/mehari/request.ml +++ b/mehari/request.ml @@ -5,6 +5,7 @@ type 'a t = { uri : Uri.t; sni : string option; params : Re.Group.t option; + client_cert : X509.Certificate.t list; } let uri { uri; _ } = uri @@ -12,10 +13,11 @@ let ip { addr; _ } = addr let port { port; _ } = port let sni { sni; _ } = sni let query { uri; _ } = Uri.verbatim_query uri +let client_cert { client_cert; _ } = client_cert let make (type a) (module Addr : Types.ADDR with type t = a) ~uri ~(addr : a) - ~port ~sni = - { uri; addr; addrm = (module Addr); port; sni; params = None } + ~port ~sni ~client_cert = + { uri; addr; addrm = (module Addr); port; sni; params = None; client_cert } let attach_params t params = { t with params }