Improve certificate authentication

.gitignore

@@ -2,3 +2,4 @@ _esy
 _build
 .merlin
 *.install
+.devcontainer.json

bin/carl.ml

@@ -86,7 +86,7 @@ type cli =
   ; h2c_upgrade : bool
   ; http2_prior_knowledge : bool
   ; tcp_nodelay : bool
-  ; cacert : string option
+  ; cacert : Cert.t
   ; capath : string option
   ; min_tls_version : Versions.TLS.t
   ; max_tls_version : Versions.TLS.t
@@ -544,10 +544,23 @@ module CLI = struct
     Arg.(
       value & opt (some request_conv) None & info [ "X"; "request" ] ~doc ~docv)
 
-  let cacert =
+  let cacertfile =
+    let cert_conv =
+      let parse s = Ok (Cert.Filepath s) in
+      Arg.conv ~docv:"method" (parse, Cert.pp_print_cert)
+    in
+    let doc = "CA certificate to verify peer against" in
+    let docv = "file" in
+    Arg.(value & opt (some cert_conv) None & info [ "cacert" ] ~doc ~docv)
+
+  let cacertpem = 
+    let cert_conv =
+      let parse s = Ok (Cert.Certpem s) in
+      Arg.conv ~docv:"method" (parse, Cert.pp_print_cert)
+    in
     let doc = "CA certificate to verify peer against" in
     let docv = "file" in
-    Arg.(value & opt (some string) None & info [ "cacert" ] ~doc ~docv)
+    Arg.(value & opt (some cert_conv) None & info [ "cacert" ] ~doc ~docv)
 
   let capath =
     let doc = "CA directory to verify peer against" in
@@ -736,7 +749,8 @@ module CLI = struct
     Arg.(non_empty & pos_all string [] & info [] ~docv)
 
   let parse
-      cacert
+      cacertpem
+      cacertfile
       capath
       compressed
       connect_timeout
@@ -810,7 +824,10 @@ module CLI = struct
           v1_0)
     ; h2c_upgrade = use_http_2
     ; http2_prior_knowledge
-    ; cacert
+    ; cacert = (match cacertpem, cacertfile with
+        | Some cert, _ -> cert
+        | None, Some cert -> cert
+        | _ -> Empty)
     ; capath
     ; min_tls_version =
         (* select the _maximum_ min version *)
@@ -845,7 +862,8 @@ module CLI = struct
   let default_cmd =
     Term.(
       const parse
-      $ cacert
+      $ cacertpem
+      $ cacertfile
       $ capath
       $ compressed
       $ connect_timeout

lib/cert.ml

@@ -0,0 +1,40 @@
+(*----------------------------------------------------------------------------
+ * Copyright (c) 2021, Ezequiel Lewin
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ *    this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ *    this list of conditions and the following disclaimer in the documentation
+ *    and/or other materials provided with the distribution.
+ *
+ * 3. Neither the name of the copyright holder nor the names of its
+ *    contributors may be used to endorse or promote products derived from
+ *    this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *---------------------------------------------------------------------------*)
+
+ type t = 
+  | Empty
+  | Filepath of string
+  | Certpem of string
+
+ let pp_print_cert ppf = function
+  | Empty -> Format.pp_print_string ppf "Empty" 
+  | Filepath s ->  Format.pp_print_string ppf s
+  | Certpem s -> Format.pp_print_string ppf s

lib/config.ml

@@ -56,10 +56,13 @@ type t =
         (** Assume HTTP/2 prior knowledge -- don't use HTTP/1.1 Upgrade when
             communicating with "http" URIs, default to HTTP/2.0 when we can't
             agree to an ALPN protocol and communicating with "https" URIs. *)
-  ; cacert : string option
-        (** The path to a CA certificates file in PEM format *)
+  ; cacert : Cert.t
+        (** Either the certificates string or path to a file with certificates to 
+            verify peer. Both should be in PEM format *)
   ; capath : string option
         (** The path to a directory which contains CA certificates in PEM format *)
+  ; clientcert: (string * string) option
+        (** Client certificate in PEM format and private key *)
   ; min_tls_version : Versions.TLS.t
   ; max_tls_version : Versions.TLS.t
   ; tcp_nodelay : bool
@@ -83,8 +86,9 @@ let default =
   ; max_http_version = Versions.HTTP.v2_0
   ; http2_prior_knowledge = false
   ; h2c_upgrade = false
-  ; cacert = None
+  ; cacert = Empty
   ; capath = None
+  ; clientcert = None
   ; min_tls_version = TLSv1_0
   ; max_tls_version = TLSv1_3
   ; tcp_nodelay = true

lib/openssl.ml

@@ -102,6 +102,12 @@ let log_cert_info ~allow_insecure ssl_sock =
         (pp_cert_verify_result ~allow_insecure)
         verify_result)
 
+let load_client_cert cert privkey ctx =
+  Ssl.use_certificate_from_string ctx cert privkey
+
+let load_peer_ca_cert cert ctx =
+  Ssl.add_cert_to_store ctx cert
+
 let load_verify_locations ?(cacert = "") ?(capath = "") ctx =
   match Ssl.load_verify_locations ctx cacert capath with
   | () ->
@@ -241,6 +247,7 @@ let connect ~hostname ~config ~alpn_protocols fd =
   let { Config.allow_insecure
       ; cacert
       ; capath
+      ; clientcert
       ; min_tls_version
       ; max_tls_version
       ; _
@@ -293,10 +300,30 @@ let connect ~hostname ~config ~alpn_protocols fd =
            * Ssl.get_verify_result.
            * https://www.openssl.org/docs/man1.1.1/man3/SSL_CTX_set_verify.html *)
           Ssl.set_verify ctx [ Ssl.Verify_peer ] None;
-          (* Don't bother configuring verify locations if we're not going to be
-             verifying the peer. *)
-          configure_verify_locations ctx cacert capath)
+
+          (* Server certificate verification *)
+          let certio = 
+            match cacert with 
+            | Empty -> configure_verify_locations ctx None capath
+            | Filepath path -> 
+              let somepath = Some(path) in
+              configure_verify_locations ctx somepath capath
+            | Certpem cert -> Lwt_result.return (load_peer_ca_cert cert ctx)
+          in
+
+          (* Send client cert if present *)
+          let clientcertio = match clientcert with
+            | Some certwithkey -> 
+              let cert, privkey = certwithkey in
+              Lwt_result.return (load_client_cert cert privkey ctx)
+            | None -> Lwt_result.return ()
+          in
+
+          Lwt.bind certio (fun _ -> clientcertio)
+        )
         else
+          (* Don't bother configuring verify locations if we're not going to be
+            verifying the peer. *)
           Lwt_result.return ()
       in
       let s = Lwt_ssl.embed_uninitialized_socket fd ctx in

lib/piaf.ml

@@ -30,6 +30,7 @@
  *---------------------------------------------------------------------------*)
 
 module Body = Body
+module Cert = Cert
 module Config = Config
 module Client = Client
 module Error = Error

lib/piaf.mli

@@ -263,6 +263,15 @@ module Versions : sig
   end
 end
 
+module Cert: sig
+  type t = 
+  | Empty
+  | Filepath of string
+  | Certpem of string
+
+  val pp_print_cert : Format.formatter -> t -> unit
+end
+
 module Config : sig
   type t =
     { follow_redirects : bool  (** whether to follow redirects *)
@@ -280,11 +289,13 @@ module Config : sig
           (** Assume HTTP/2 prior knowledge -- don't use HTTP/1.1 Upgrade when
               communicating with "http" URIs, default to HTTP/2.0 when we can't
               agree to an ALPN protocol and communicating with "https" URIs. *)
-    ; cacert : string option
+    ; cacert : Cert.t
           (** The path to a CA certificates file in PEM format *)
     ; capath : string option
           (** The path to a directory which contains CA certificates in PEM
               format *)
+    ; clientcert: (string * string) option
+          (** Client certificate in PEM format *)
     ; min_tls_version : Versions.TLS.t
     ; max_tls_version : Versions.TLS.t
     ; tcp_nodelay : bool

lib_test/certificates/ca.key

@@ -0,0 +1,6 @@
+-----BEGIN PRIVATE KEY-----
+MIG2AgEAMBAGByqGSM49AgEGBSuBBAAiBIGeMIGbAgEBBDDPqZbM25scc6XqGE4m
+v76i0qo4vpdoqkIOxRxU5EIPr0L6D77nZ0rO/Y6F1JzI5bChZANiAATUzXZLuPAt
+OPvbwVKK13YscOeQf3382Q/G/d7iiUEw7+2nOT8bMb1yun+Ngw3XVKcJQ7CUb7X+
+0rSTPwkMhbh3VkuZdDn5jQUP03R+HbYeAIg6tb3kef1X/tSNzI8rrAU=
+-----END PRIVATE KEY-----

lib_test/certificates/ca.pem

@@ -0,0 +1,14 @@
+-----BEGIN CERTIFICATE-----
+MIICHTCCAaKgAwIBAgIUKrnJBkhXvmeHDoTJnUZKtxospSwwCgYIKoZIzj0EAwIw
+RTELMAkGA1UEBhMCVVMxEzARBgNVBAgMClNvbWUtU3RhdGUxITAfBgNVBAoMGElu
+dGVybmV0IFdpZGdpdHMgUHR5IEx0ZDAeFw0yMTA0MDcxNDEzMzFaFw0yMTA1MDcx
+NDEzMzFaMEUxCzAJBgNVBAYTAlVTMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYD
+VQQKDBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQwdjAQBgcqhkjOPQIBBgUrgQQA
+IgNiAATUzXZLuPAtOPvbwVKK13YscOeQf3382Q/G/d7iiUEw7+2nOT8bMb1yun+N
+gw3XVKcJQ7CUb7X+0rSTPwkMhbh3VkuZdDn5jQUP03R+HbYeAIg6tb3kef1X/tSN
+zI8rrAWjUzBRMB0GA1UdDgQWBBT+PDDOkJJnKruI8O5hbeiCPCRHXjAfBgNVHSME
+GDAWgBT+PDDOkJJnKruI8O5hbeiCPCRHXjAPBgNVHRMBAf8EBTADAQH/MAoGCCqG
+SM49BAMCA2kAMGYCMQDl2ishDpxoavrP9RnwH1OwvlV24qJ+9xQLDyEvGCLqsnkr
+iotPf6TgMb9/yfWEQI8CMQD1uPEy3Hh1qzTVyjX1DzC4pxT7WE4IiMoMEKYIGeNs
+dhrAZCqBEP2ZQjC8dppJCIA=
+-----END CERTIFICATE-----

lib_test/certificates/client.key

@@ -0,0 +1,6 @@
+-----BEGIN PRIVATE KEY-----
+MIG2AgEAMBAGByqGSM49AgEGBSuBBAAiBIGeMIGbAgEBBDDen+iNN4z3SwRYHhk2
+XVWg2eWv+bdYOm3NhgjkpE2IgRsJ/q795tii0CYwN+/VfPahZANiAAQELi9Nxe8E
+XlxGw7V1kP0v7QNefkGROoTmBj34I8zjpsb2yqOcsOwBpLh2boKjhndvhMBwJ3Xb
+G5gE6CHn1fA3SXxT8nnFrDnBPt78VXBmKiGmIGIPzFs5Gw2MZjaVUZ8=
+-----END PRIVATE KEY-----

lib_test/certificates/client.pem

@@ -0,0 +1,13 @@
+-----BEGIN CERTIFICATE-----
+MIIB5zCCAW0CFEIxgbTD+hy6B+6oxNSCHRgytXoBMAoGCCqGSM49BAMCMEUxCzAJ
+BgNVBAYTAlVTMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
+dCBXaWRnaXRzIFB0eSBMdGQwIBcNMjEwNDEwMDQzMzAwWhgPMjEyMTAzMTcwNDMz
+MDBaMGgxCzAJBgNVBAYTAlVTMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQK
+DBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQxDzANBgNVBAMMBmNsaWVudDEQMA4G
+CSqGSIb3DQEJARYBfTB2MBAGByqGSM49AgEGBSuBBAAiA2IABAQuL03F7wReXEbD
+tXWQ/S/tA15+QZE6hOYGPfgjzOOmxvbKo5yw7AGkuHZugqOGd2+EwHAnddsbmATo
+IefV8DdJfFPyecWsOcE+3vxVcGYqIaYgYg/MWzkbDYxmNpVRnzAKBggqhkjOPQQD
+AgNoADBlAjEAkNdSbPFl7vmYJE4mTvrjCIOohFUGK4qmBSdtF+RFeh6u/eAsqZ0H
+Zx0W0t4LP1uWAjAmxZPAaAVqkaN8oXLQRFnlbmcWntnltpb47+UUdPu8Rip8UjkF
+mCRLarrU+b0S+tw=
+-----END CERTIFICATE-----

lib_test/certificates/server.key

@@ -1,15 +1,6 @@
------BEGIN RSA PRIVATE KEY-----
-MIICXQIBAAKBgQC2QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJv
-K+aOANKIsOOr9v4RiEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTRE
-BE/t1soVT3a/vVJWCLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQAB
-AoGAd/CShG8g/JBMh9Nz/8KAuKHRHc2BvysIM1C62cSosgaFmdRrazJfBrEv3Nlc
-2/0uc2dVYIxuvm8bIFqi2TWOdX9jWJf6oXwEPXCD0SaDbJTaoh0b+wjyHuaGlttY
-Ztvmf8mK1BOhyl3vNMxh/8Re0dGvGgPZHpn8zanaqfGVz+ECQQDngieUpwzxA0QZ
-GZKRYhHoLEaPiQzBaXphqWcCLLN7oAKxZlUCUckxRRe0tKINf0cB3Kr9gGQjPpm0
-YoqXo8mNAkEAyYgdd+JDi9FH3Cz6ijvPU0hYkriwTii0V09+Ar5DvYQNzNEIEJu8
-Q3Yte/TPRuK8zhnp97Bsy9v/Ji/LSWbtZQJBAJe9y8u3otfmWCBLjrIUIcCYJLe4
-ENBFHp4ctxPJ0Ora+mjkthuLF+BfdSZQr1dBcX1a8giuuvQO+Bgv7r9t75ECQC7F
-omEyaA7JEW5uGe9/Fgz0G2ph5rkdBU3GKy6jzcDsJu/EC6UfH8Bgawn7tSd0c/E5
-Xm2Xyog9lKfeK8XrV2kCQQCTico5lQPjfIwjhvn45ALc/0OrkaK0hQNpXgUNFJFQ
-tuX2WMD5flMyA5PCx5XBU8gEMHYa8Kr5d6uoixnbS0cZ
------END RSA PRIVATE KEY-----
+-----BEGIN PRIVATE KEY-----
+MIG2AgEAMBAGByqGSM49AgEGBSuBBAAiBIGeMIGbAgEBBDCxGFrzabPSC68CDH22
+pNiHrbbY4sWu8ptb+lVbw4cJHZ7FYqK4qSQf4N8KrWkjW8mhZANiAARF6n8K1nt3
+3kKGiDRicK81UvPguGJrlCCsOVIc9VjeyF2EhLEXuWe/vOGJ6rTj0jwv8g6343pE
+W4xtqkL+JcNb+GhnPECKlqdKHTGKTfHyzEuLqS39o81C/oQzbD2ApQk=
+-----END PRIVATE KEY-----

lib_test/certificates/server.pem

@@ -1,15 +1,12 @@
 -----BEGIN CERTIFICATE-----
-MIICYzCCAcwCCQDLbE6ES1ih1DANBgkqhkiG9w0BAQUFADB2MQswCQYDVQQGEwJB
-VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0
-cyBQdHkgTHRkMRUwEwYDVQQDDAxZT1VSIE5BTUUhISExGDAWBgkqhkiG9w0BCQEW
-CW1lQGJhci5kZTAeFw0xNDAyMTcyMjA4NDVaFw0xNTAyMTcyMjA4NDVaMHYxCzAJ
-BgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
-dCBXaWRnaXRzIFB0eSBMdGQxFTATBgNVBAMMDFlPVVIgTkFNRSEhITEYMBYGCSqG
-SIb3DQEJARYJbWVAYmFyLmRlMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC2
-QEje5rwhlD2iq162+Ng3AH9BfA/jNJLDqi9VPk1eMUNGicJvK+aOANKIsOOr9v4R
-iEXZSYmFEvGSy+Sf1bCDHwHLLSdNs6Y49b77POgatrVZOTREBE/t1soVT3a/vVJW
-CLtVCjm70u0S5tcfn4S6IapeIYAVAmcaqwSa+GQNoQIDAQABMA0GCSqGSIb3DQEB
-BQUAA4GBAIo4ZppIlp3JRyltRC1/AyCC0tsh5TdM3W7258wdoP3lEe08UlLwpnPc
-aJ/cX8rMG4Xf4it77yrbVrU3MumBEGN5TW4jn4+iZyFbp6TT3OUF55nsXDjNHBbu
-deDVpGuPTI6CZQVhU5qEMF3xmlokG+VV+HCDTglNQc+fdLM0LoNF
+MIIB1zCCAV4CFEIxgbTD+hy6B+6oxNSCHRgytXoCMAoGCCqGSM49BAMCMEUxCzAJ
+BgNVBAYTAlVTMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5l
+dCBXaWRnaXRzIFB0eSBMdGQwIBcNMjEwNDEwMDQzNTI4WhgPMjEyMTAzMTcwNDM1
+MjhaMFkxCzAJBgNVBAYTAlVTMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQK
+DBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQxEjAQBgNVBAMMCWxvY2FsaG9zdDB2
+MBAGByqGSM49AgEGBSuBBAAiA2IABEXqfwrWe3feQoaINGJwrzVS8+C4YmuUIKw5
+Uhz1WN7IXYSEsRe5Z7+84YnqtOPSPC/yDrfjekRbjG2qQv4lw1v4aGc8QIqWp0od
+MYpN8fLMS4upLf2jzUL+hDNsPYClCTAKBggqhkjOPQQDAgNnADBkAjA3ahx8PzKg
+mMg5qeU/KsOrZ4p7x9eEkzwMdnxDsKK8CYNrMTlnRKd7G41Ri+OY+yQCMDKPJ8sa
+BmdyyhCOE5xpvVnliBfJboEI5ufdV4T3wFQ8nTxwxhFj+c9nWR3ka1Z7Eg==
 -----END CERTIFICATE-----

lib_test/helper_server.ml

@@ -98,17 +98,20 @@ module ALPN = struct
     | _ :: xs ->
       first_match l1 xs
 
-  let https_server port =
+  let https_server ?(check_client_cert=false) port =
     let open Lwt.Infix in
     let listen_address = Unix.(ADDR_INET (inet_addr_loopback, port)) in
+    let ca = "./certificates/ca.pem" in
     let cert = "./certificates/server.pem" in
     let priv_key = "./certificates/server.key" in
     Lwt_io.establish_server_with_client_socket
       listen_address
       (fun client_addr fd ->
         let server_ctx = Ssl.create_context Ssl.TLSv1_3 Ssl.Server_context in
         Ssl.disable_protocols server_ctx [ Ssl.SSLv23; Ssl.TLSv1_1 ];
+        Ssl.load_verify_locations server_ctx ca "";
         Ssl.use_certificate server_ctx cert priv_key;
+        if check_client_cert then Ssl.set_verify server_ctx [Ssl.Verify_fail_if_no_peer_cert] None;
         let protos = [ "h2"; "http/1.1" ] in
         Ssl.set_context_alpn_protos server_ctx protos;
         Ssl.set_context_alpn_select_callback server_ctx (fun client_protos ->
@@ -136,9 +139,14 @@ end
 
 type t = Lwt_io.server * Lwt_io.server
 
-let listen ?(http_port = 8080) ?(https_port = 9443) () =
+let listen ?(http_port = 8080) ?(https_port = 9443) ?(check_client_cert=false) () =
   let http_server = HTTP.listen http_port in
-  let https_server = ALPN.https_server https_port in
+  let https_server =
+    if check_client_cert then
+      ALPN.https_server https_port ~check_client_cert:true
+    else
+      ALPN.https_server https_port
+  in
   Lwt.both http_server https_server
 
 let teardown (http, https) =

lib_test/helper_server.mli

@@ -1,6 +1,6 @@
 type t
 
-val listen : ?http_port:int -> ?https_port:int -> unit -> t Lwt.t
+val listen : ?http_port:int -> ?https_port:int -> ?check_client_cert:bool -> unit -> t Lwt.t
 
 val teardown : t -> unit Lwt.t