Move SSL fingerprint verification to the the verify callback.

2 files changed, 24 insertions, 23 deletions

diff --git a/interimap.1 b/interimap.1
index d0c5474..60493f3 100644
--- a/interimap.1
+++ b/interimap.1
@@ -317,8 +317,8 @@ Fingerprint of the server certificate (or its public key) in the form
 \fIALGO\fR$\fIDIGEST_HEX\fR, where \fIALGO\fR is the used algorithm
 (default \(lqsha256\(rq).
 Attempting to connect to a server with a non-matching certificate
-fingerprint causes \fBInterIMAP\fR to abort the connection immediately
-after the SSL/TLS handshake.
+fingerprint causes \fBInterIMAP\fR to abort the connection during the
+SSL/TLS handshake.
 
 .TP
 .I SSL_verify
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index f54f239..bf33294 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -1380,7 +1380,8 @@ sub _ssl_verify($$$) {
         $self->log('  Subject Name: ', Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert)));
     }
 
-    if ($depth == 0) {
+    $ok = 1 unless $self->{SSL_verify} // 1;
+    if ($depth == 0 and !exists $self->{_SSL_PEER_VERIFIED}) {
         if ($self->{debug}) {
             my $algo = 'sha256';
             my $type = Net::SSLeay::EVP_get_digestbyname($algo)
@@ -1388,6 +1389,21 @@ sub _ssl_verify($$$) {
             $self->log('Peer certificate fingerprint: '
                       .$algo.'$'.unpack('H*', Net::SSLeay::X509_digest($cert, $type)));
         }
+
+        if (defined (my $fpr = $self->{SSL_fingerprint})) {
+            (my $algo, $fpr) = $fpr =~ /^([^\$]+)\$(.*)/ ? ($1, $2) : ('sha256', $fpr);
+            my $digest = pack 'H*', ($fpr =~ tr/://rd);
+
+            my $type = Net::SSLeay::EVP_get_digestbyname($algo)
+                or $self->_ssl_error("Can't find MD value for name '$algo'");
+
+            if (Net::SSLeay::X509_digest($cert, $type) ne $digest and
+                Net::SSLeay::X509_pubkey_digest($cert, $type) ne $digest) {
+                $self->warn("Fingerprint doesn't match!  MiTM in action?");
+                $ok = 0;
+            }
+        }
+        $self->{_SSL_PEER_VERIFIED} = $ok;
     }
     return $ok; # 1=accept cert, 0=reject
 }
@@ -1426,17 +1442,18 @@ 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(), sub($$) {$self->_ssl_verify(@_)});
-        Net::SSLeay::CTX_set_purpose($ctx, Net::SSLeay::X509_PURPOSE_SSL_SERVER())
-                or $self->_ssl_error("Can't set purpose");
     }
     else {
-        Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_NONE());
+        Net::SSLeay::CTX_set_verify_depth($ctx, 0);
     }
+    Net::SSLeay::CTX_set_purpose($ctx, Net::SSLeay::X509_PURPOSE_SSL_SERVER())
+        or $self->_ssl_error("Can't set purpose");
+    Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER(), sub($$) {$self->_ssl_verify(@_)});
 
     my $ssl = Net::SSLeay::new($ctx) or $self->fail("Can't create new SSL structure");
     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;
+    $self->panic("Couldn't verify") unless $self->{_SSL_PEER_VERIFIED}; # sanity check
 
     if ($self->{debug}) {
         my $v = Net::SSLeay::version($ssl);
@@ -1452,22 +1469,6 @@ sub _start_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);
-        my $digest = pack 'H*', ($fpr =~ tr/://rd);
-
-        my $type = Net::SSLeay::EVP_get_digestbyname($algo)
-            or $self->_ssl_error("Can't find MD value for name '$algo'");
-
-        my $cert = Net::SSLeay::get_peer_certificate($ssl)
-            or $self->_ssl_error("Can't get peer certificate");
-
-        $self->fail("Fingerprint doesn't match!  MiTM in action?")
-            if Net::SSLeay::X509_digest($cert, $type) ne $digest and
-               Net::SSLeay::X509_pubkey_digest($cert, $type) ne $digest;
-    }
-
     @$self{qw/_SSL _SSL_CTX/} = ($ssl, $ctx);
 }