Client certificate. (#24)

Co-authored-by: Tim-ats-d <[email protected]>

.gitignore

@@ -31,3 +31,7 @@ _opam/
 
 # Certificates
 *.pem
+
+# Sublime Text
+*.sublime-project
+*.sublime-workspace

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

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

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 ->

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
 

mehari/dune

@@ -8,4 +8,5 @@
   magic-mime
   mirage-clock
   uri
-  zed))
+  zed
+  x509))

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

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

mehari/request.ml

@@ -5,17 +5,19 @@ type 'a t = {
   uri : Uri.t;
   sni : string option;
   params : Re.Group.t option;
+  client_cert : X509.Certificate.t list;
 }
 
 let uri { uri; _ } = uri
 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 }