Merge branch 'master' into debian

6 files changed, 109 insertions, 82 deletions

diff --git a/Changelog b/Changelog
index 9d864f8..8cd8be2 100644
--- a/Changelog
+++ b/Changelog
@@ -6,10 +6,6 @@ interimap (0.2) upstream;
     server.
   * Add a configuration option 'null-stderr=YES' to send STDERR to
     /dev/null for type=tunnel.
-  * Add support for the Binary Content extension [RFC3516].  Enabled by
-    default if both the local and remote servers advertize "BINARY".
-	Can be disabled by adding 'use-binary=NO' to the default section in
-	the configuration file.
   * Exit with return value 0 when receiving a SIGTERM.
   * Add SSL options SINGLE_ECDH_USE, SINGLE_DH_USE, NO_SSLv2, NO_SSLv3
     and NO_COMPRESSION to the compiled-in CTX options.
@@ -17,7 +13,7 @@ interimap (0.2) upstream;
     handshake.
   * Rename the 'SSL_verify_trusted_peer', 'SSL_ca_path', and
     'SSL_cipher_list' options to 'SSL_CApath', 'SSL_verify' and
-	'SSL_cipherlist', respectively.
+    'SSL_cipherlist', respectively.
   * Add an option 'SSL_CAfile' to specify a file containing trusted
     certificates to use during server certificate authentication.
   * Replace IO::Socket::SSL dependency by the lower level Net::SSLeay.
@@ -26,6 +22,9 @@ interimap (0.2) upstream;
     IPv6.  (Both are core Perl module.)
   * Add a configuration option 'proxy' to proxy TCP connections to the
     IMAP server.
+  * 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/README b/README
index 2809ccb..bf2e052 100644
--- a/README
+++ b/README
@@ -28,9 +28,8 @@ extensions are:
   * LITERAL+ [RFC2088] non-synchronizing literals (recommended),
   * MULTIAPPEND [RFC3502] (recommended),
   * COMPRESS=DEFLATE [RFC4978] (recommended),
-  * SASL-IR [RFC4959] SASL Initial Client Response,
-  * UNSELECT [RFC3691], and
-  * BINARY [RFC3516].
+  * SASL-IR [RFC4959] SASL Initial Client Response, and
+  * UNSELECT [RFC3691].
 
 
 #######################################################################
diff --git a/interimap b/interimap
index b3a7342..54ae0aa 100755
--- a/interimap
+++ b/interimap
@@ -74,7 +74,6 @@ my $CONF = read_config( delete $CONFIG{config} // $NAME
                       , 'list-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
                       , 'list-select-opts' => qr/\A([\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]+)\z/
                       , 'ignore-mailbox' => qr/\A([\x01-\x09\x0B\x0C\x0E-\x7F]+)\z/
-                      , 'use-binary' => qr/\A(YES|NO)\z/i,
                       );
 my ($DBFILE, $LOCKFILE, $LOGGER_FD);
 
@@ -249,6 +248,7 @@ foreach my $name (qw/local remote/) {
     $config{name} = $name;
     $config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD;
     $config{'compress'} //= ($name eq 'local' ? 0 : 1);
+    $config{keepalive} = 1 if $CONFIG{watch} and $config{type} ne 'tunnel';
 
     $IMAP->{$name} = { client => Net::IMAP::InterIMAP::->new(%config) };
     my $client = $IMAP->{$name}->{client};
@@ -512,10 +512,7 @@ sub sync_mailbox_list() {
 
 sync_mailbox_list();
 ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
-my $ATTRS = 'MODSEQ FLAGS INTERNALDATE '.
-            (((!defined $CONF->{_} or $CONF->{_}->{'use-binary'} // 1) and
-             !$lIMAP->incapable('BINARY') and !$rIMAP->incapable('BINARY'))
-                ? 'BINARY' : 'BODY').'.PEEK[]';
+my $ATTRS = join ' ', qw/MODSEQ FLAGS INTERNALDATE BODY.PEEK[]/;
 
 
 #############################################################################
@@ -600,7 +597,7 @@ sub download_missing($$$@) {
     my $attrs = $ATTRS.' ENVELOPE';
     ($source eq 'local' ? $lIMAP : $rIMAP)->fetch(compact_set(@set), "($attrs)", sub($) {
         my $mail = shift;
-        return unless exists $mail->{RFC822} or exists $mail->{BINARY}; # not for us
+        return unless exists $mail->{RFC822}; # not for us
 
         my $uid = $mail->{UID};
         my $from = first { defined $_ and @$_ } @{$mail->{ENVELOPE}}[2,3,4];
@@ -969,10 +966,9 @@ sub sync_known_messages($$) {
 # after the FETCH.
 sub callback_new_message($$$$;$$$) {
     my ($idx, $mailbox, $name, $mail, $UIDs, $buff, $bufflen) = @_;
+    return unless exists $mail->{RFC822}; # not for us
 
-    my $length = defined $mail->{RFC822} ? length(${$mail->{RFC822}})
-               : defined $mail->{BINARY} ? length(${$mail->{BINARY}})
-               : return; # not for us
+    my $length = length ${$mail->{RFC822}};
     if ($length == 0) {
         msg("$name($mailbox)", "WARNING: Ignoring new 0-length message (UID $mail->{UID})");
         return;
diff --git a/interimap.1 b/interimap.1
index 621d968..60493f3 100644
--- a/interimap.1
+++ b/interimap.1
@@ -305,18 +305,6 @@ for type \fItype\fR=tunnel.
 (Default: \(lqNO\(rq.)
 
 .TP
-.I use-binary
-Whether to use the Binary Content extension [RFC3516] in FETCH and
-APPEND commands.
-This is useful for binary attachments for instance, as it avoids the
-overhead caused by base64 encodings.  Moreover if the IMAP COMPRESS
-extension is enabled, full flush points are placed around large non-text
-literals to empty the compression dictionary.
-This option is only available in the default section, and is ignored if
-either server does not advertize \(lqBINARY\(rq in its capability list.
-(Default: \(lqYES\(rq.)
-
-.TP
 .I SSL_cipher_list
 The cipher list to send to the server.  Although the server determines
 which cipher suite is used, it should take the first supported cipher in
@@ -329,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
@@ -364,11 +352,9 @@ MULTIAPPEND [RFC3502] (recommended),
 .IP \[bu]
 COMPRESS=DEFLATE [RFC4978] (recommended),
 .IP \[bu]
-SASL-IR [RFC4959] SASL Initial Client Response,
-.IP \[bu]
-UNSELECT [RFC3691], and
+SASL-IR [RFC4959] SASL Initial Client Response, and
 .IP \[bu]
-BINARY [RFC3516].
+UNSELECT [RFC3691].
 
 .SH KNOWN BUGS AND LIMITATIONS
 
diff --git a/interimap.sample b/interimap.sample
index 5d9d6d2..6d52f91 100644
--- a/interimap.sample
+++ b/interimap.sample
@@ -2,7 +2,6 @@
 #list-mailbox = "*"
 list-select-opts = SUBSCRIBED
 ignore-mailbox = ^virtual/
-#use-binary = YES
 
 [local]
 type = tunnel
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 6f44879..d6c46a8 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -26,7 +26,7 @@ use IO::Select ();
 use Net::SSLeay ();
 use List::Util 'first';
 use POSIX ':signal_h';
-use Socket qw/SOL_SOCKET SO_KEEPALIVE SOCK_STREAM IPPROTO_TCP AF_INET AF_INET6 SOCK_RAW :addrinfo/;
+use Socket qw/SOCK_STREAM IPPROTO_TCP AF_INET AF_INET6 SOCK_RAW :addrinfo/;
 
 use Exporter 'import';
 BEGIN {
@@ -228,6 +228,9 @@ our $IMAP_text;
 #
 #   - 'logger-fd': An optional filehandle to use for debug output.
 #
+#   - 'keepalive': Whether to enable sending of keep-alive messages.
+#     (type=imap or type=imaps).
+#
 sub new($%) {
     my $class = shift;
     my $self = { @_ };
@@ -289,7 +292,23 @@ sub new($%) {
         }
         my $socket = defined $self->{proxy} ? $self->_proxify(@$self{qw/proxy host port/})
                                             : $self->_tcp_connect(@$self{qw/host port/});
-        setsockopt($socket, SOL_SOCKET, SO_KEEPALIVE, 1) or $self->fail("Can't setsockopt SO_KEEPALIVE: $!");
+        my ($cnt, $intvl) = (3, 5);
+        if (defined $self->{keepalive}) {
+            # detect dead peers and drop the connection after 60 secs + $cnt*$intvl
+            setsockopt($socket, Socket::SOL_SOCKET, Socket::SO_KEEPALIVE, 1)
+                or $self->fail("Can't setsockopt SO_KEEPALIVE: $!");
+            setsockopt($socket, Socket::IPPROTO_TCP, Socket::TCP_KEEPIDLE, 60)
+                or $self->fail("Can't setsockopt TCP_KEEPIDLE: $!");
+            setsockopt($socket, Socket::IPPROTO_TCP, Socket::TCP_KEEPCNT, $cnt)
+                or $self->fail("Can't setsockopt TCP_KEEPCNT: $!");
+            setsockopt($socket, Socket::IPPROTO_TCP, Socket::TCP_KEEPINTVL, $intvl)
+                or $self->fail("Can't setsockopt TCP_KEEPINTVL: $!");
+        }
+        # Abort after 15secs if write(2) isn't acknowledged
+        # XXX Socket::TCP_USER_TIMEOUT isn't defined.
+        # `grep TCP_USER_TIMEOUT /usr/include/linux/tcp.h` gives 18
+        setsockopt($socket, Socket::IPPROTO_TCP, 18, 1000 * $cnt * $intvl)
+            or $self->fail("Can't setsockopt TCP_USER_TIMEOUT: $!");
 
         $self->_start_ssl($socket) if $self->{type} eq 'imaps';
         $self->{$_} = $socket for qw/STDOUT STDIN/;
@@ -772,9 +791,7 @@ sub remove_message($@) {
 #   Issue an APPEND command with the given mails.  Croak if the server
 #   did not advertise "UIDPLUS" (RFC 4315) in its CAPABILITY list.
 #   Each $mail is a hash reference with key 'RFC822' and optionally
-#   'FLAGS' and 'INTERNALDATE'.  If the server supports the "BINARY"
-#   extension (RFC 3516), the key 'RFC822' can be replaced with 'BINARY'
-#   to send the mail body as a binary literal.
+#   'FLAGS' and 'INTERNALDATE'.
 #   Providing multiple mails is only allowed for servers supporting
 #   "MULTIAPPEND" (RFC 3502).
 #   Return the list of UIDs allocated for the new messages.
@@ -801,11 +818,8 @@ sub append($$@) {
         my $str = ' ';
         $str .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') ' if defined $mail->{FLAGS};
         $str .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE};
-        my ($body, $t) = defined $mail->{RFC822} ? ($mail->{RFC822}, 0)
-                       : defined $mail->{BINARY} ? ($mail->{BINARY}, 1)
-                       : $self->panic("Missing message body in APPEND");
         $self->_cmd_extend(\$str);
-        $self->_cmd_extend_lit($body, $t);
+        $self->_cmd_extend_lit($mail->{RFC822} // $self->panic("Missing message body in APPEND"));
     }
 
     $self->_cmd_flush();
@@ -1075,8 +1089,7 @@ sub pull_updates($;$) {
 #   FETCH new messages since the UIDNEXT found in the persistent cache
 #   (or 1 in no such UIDNEXT is found), and process each response on the
 #   fly with the callback.
-#   The list of attributes to FETCH, $attr, much contain either BODY or
-#   BINARY.
+#   The list of attributes to FETCH, $attr, must contain BODY[].
 #   If an @ignore list is supplied, then these messages are ignored from
 #   the UID FETCH range.
 #   Finally, update the UIDNEXT from the persistent cache to the value
@@ -1371,6 +1384,51 @@ 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)));
+    }
+
+    $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)
+                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)));
+        }
+
+        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
+}
+
+
 # $self->_start_ssl($socket)
 #   Upgrade the $socket to SSL/TLS.
 sub _start_ssl($$) {
@@ -1404,30 +1462,31 @@ 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());
     }
     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 (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;
+    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)));
     }
 
     @$self{qw/_SSL _SSL_CTX/} = ($ssl, $ctx);
@@ -1582,20 +1641,17 @@ sub _cmd_extend($$) {
 }
 
 
-# $self->_cmd_extend_lit($lit, [$lit8])
+# $self->_cmd_extend_lit($lit)
 #   Append the literal $lit to the command buffer.  $lit must be a
-#   scalar reference.  If $lit8 is true, a literal8 is sent instead [RFC
-#   3516].
-sub _cmd_extend_lit($$;$) {
-    my ($self, $lit, $lit8) = @_;
+#   scalar reference.
+sub _cmd_extend_lit($$) {
+    my ($self, $lit) = @_;
     my $len = length($$lit);
     my $d = $self->{_Z_DEFLATE};
 
-    # create a full flush point for long binary literals
-    my $z_flush = ($len > 4096 and !($self->{'use-binary'} // 1 and !$lit8)) ? 1 : 0;
-    $lit8 = $lit8 ? '~' : ''; # literal8, RFC 3516 BINARY
-
-    my $strlen = $lit8.'{'.$len.$self->{_LITPLUS}.'}'.$CRLF;
+    # create a full flush point for long literals, cf. RFC 4978 section 4
+    my $z_flush = $len > $BUFSIZE ? 1 : 0;
+    my $strlen = "{$len$self->{_LITPLUS}}$CRLF";
 
     if ($self->{_LITPLUS} ne '') {
         $self->_cmd_extend_(\$strlen);
@@ -2086,14 +2142,6 @@ sub _resp($$;$$$) {
                 elsif (s/\A(?:RFC822|BODY\[\]) //) {
                     $mail{RFC822} = \$self->_nstring(\$_);
                 }
-                elsif (s/\ABINARY\[\] //) {
-                    if (s/\A~\{([0-9]+)\}\z//) { # literal8, RFC 3516 BINARY
-                        (my $lit, $_) = $self->_getline($1);
-                        $mail{BINARY} = $lit;
-                    } else {
-                        $mail{RFC822} = \$self->_nstring(\$_);
-                    }
-                }
                 elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) {
                     $mail{FLAGS} = defined $1 ? [ split / /, $1 ] : [];
                 }
@@ -2103,7 +2151,7 @@ sub _resp($$;$$$) {
             my $uid = $mail{UID} // $self->panic(); # sanity check
             $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check
 
-            if (!exists $mail{RFC822} and !exists $mail{BINARY} and !exists $mail{ENVELOPE} and # ignore new mails
+            if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails
                 (!exists $self->{_MODIFIED}->{$uid} or $self->{_MODIFIED}->{$uid}->[0] < $mail{MODSEQ} or
                     ($self->{_MODIFIED}->{$uid}->[0] == $mail{MODSEQ} and !defined $self->{_MODIFIED}->{$uid}->[1]))) {
                 my $flags = join ' ', sort(grep {lc $_ ne '\recent'} @{$mail{FLAGS}}) if defined $mail{FLAGS};