From cad0e125728658e4e899201e7cedc86036908057 Mon Sep 17 00:00:00 2001
From: Guilhem Moulin <guilhem@fripost.org>
Date: Wed, 16 Sep 2015 18:05:29 +0200
Subject: [PATCH] Display the certificate chain, SSL protocol and cipher in
 debug mode.

---
 Changelog                 |  2 ++
 lib/Net/IMAP/InterIMAP.pm | 45 ++++++++++++++++++++++++++++++++++++++-
 2 files changed, 46 insertions(+), 1 deletion(-)

diff --git a/Changelog b/Changelog
index 820ee6f..79a7ea4 100644
--- a/Changelog
+++ b/Changelog
@@ -26,6 +26,8 @@ interimap (0.2) upstream;
     in our case since the TCP keepalive time is usually much higher than
     the IMAP timeout.
   * Set X.509 certificate purpose to 'SSL Server' for SSL_verify=YES.
+  * Display the certificate chain, SSL protocol and cipher in debug
+    mode.
 
  -- Guilhem Moulin <guilhem@guilhem.org>  Wed, 09 Sep 2015 00:44:35 +0200
 
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 53fddec..f54f239 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -1364,6 +1364,35 @@ sub _proxify($$$$) {
 }
 
 
+# $self->_ssl_verify($self, $preverify_ok, $x509_ctx)
+#   SSL verify callback function, see
+#   https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_verify.html
+sub _ssl_verify($$$) {
+    my ($self, $ok, $x509_ctx) = @_;
+    return 0 unless $x509_ctx; # reject
+
+    my $depth = Net::SSLeay::X509_STORE_CTX_get_error_depth($x509_ctx);
+    my $cert  = Net::SSLeay::X509_STORE_CTX_get_current_cert($x509_ctx)
+        or $self->_ssl_error("Can't get current certificate");
+    if ($self->{debug}) {
+        $self->log("[$depth] preverify=$ok");
+        $self->log('  Issuer Name: ', Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_issuer_name($cert)));
+        $self->log('  Subject Name: ', Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert)));
+    }
+
+    if ($depth == 0) {
+        if ($self->{debug}) {
+            my $algo = 'sha256';
+            my $type = Net::SSLeay::EVP_get_digestbyname($algo)
+                or $self->_ssl_error("Can't find MD value for name '$algo'");
+            $self->log('Peer certificate fingerprint: '
+                      .$algo.'$'.unpack('H*', Net::SSLeay::X509_digest($cert, $type)));
+        }
+    }
+    return $ok; # 1=accept cert, 0=reject
+}
+
+
 # $self->_start_ssl($socket)
 #   Upgrade the $socket to SSL/TLS.
 sub _start_ssl($$) {
@@ -1397,7 +1426,7 @@ sub _start_ssl($$) {
             Net::SSLeay::CTX_load_verify_locations($ctx, $file, $path)
                 or $self->_ssl_error("Can't load verify locations");
         }
-        Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER());
+        Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER(), sub($$) {$self->_ssl_verify(@_)});
         Net::SSLeay::CTX_set_purpose($ctx, Net::SSLeay::X509_PURPOSE_SSL_SERVER())
                 or $self->_ssl_error("Can't set purpose");
     }
@@ -1409,6 +1438,20 @@ sub _start_ssl($$) {
     Net::SSLeay::set_fd($ssl, fileno $socket) or $self->fail("SSL filehandle association failed");
     $self->_ssl_error("Can't initiate TLS/SSL handshake") unless Net::SSLeay::connect($ssl) == 1;
 
+    if ($self->{debug}) {
+        my $v = Net::SSLeay::version($ssl);
+        $self->log(sprintf('SSL protocol: %s (0x%x)', ($v == 0x0002 ? 'SSLv2' :
+                                                       $v == 0x0300 ? 'SSLv3' :
+                                                       $v == 0x0301 ? 'TLSv1' :
+                                                       $v == 0x0302 ? 'TLSv1.1' :
+                                                       $v == 0x0303 ? 'TLSv1.2' :
+                                                                      '??'),
+                                                      $v));
+        $self->log(sprintf('SSL cipher: %s (%d bits)'
+                          , Net::SSLeay::get_cipher($ssl)
+                          , Net::SSLeay::get_cipher_bits($ssl)));
+    }
+
     if (defined (my $fpr = $self->{SSL_fingerprint})) {
         # ensure we're talking to the right server
         (my $algo, $fpr) = $fpr =~ /^([^\$]+)\$(.*)/ ? ($1, $2) : ('sha256', $fpr);
-- 
2.39.2