From 39faf86e122fefe4a8093f3b6609658c56c696c0 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 8 Jul 2019 05:30:37 +0200 Subject: libinterimap: use directories relative to $HOME for the XDG defaults. Previously getpwuid() was called to determine the user's home directory, while the XDG specification explicitely mentions $HOME. Conveniently our docs always mentioned ~/, which on POSIX-compliant systems expands to the value of the variable HOME (and the result is unspecified when the variable is unset). Cf. Shell and Utilities volume of POSIX.1-2017, sec. 2.6.1: https://pubs.opengroup.org/onlinepubs/9699919799/utilities/V3_chap02.html#tag_18_06_01 --- lib/Net/IMAP/InterIMAP.pm | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 19895c4..aacc8e7 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -92,11 +92,9 @@ sub xdg_basedir($$$$) { return $path if $path =~ /\A\//; my $basedir = $ENV{$xdg_variable}; - unless (defined $basedir) { - my @getent = getpwuid($>); - $basedir = $getent[7] ."/". $default; - } + $basedir = ($ENV{HOME} // "") ."/". $default unless defined $basedir; die "No such directory: ", $basedir unless -d $basedir; + $basedir .= "/".$subdir; $basedir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $basedir"; $basedir = $1; -- cgit v1.2.3 From 2f8350700091e766bdab24e7e8d8e051701da9e2 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Wed, 6 Nov 2019 02:55:18 +0100 Subject: pullimap, interimap: redact AUTHENTICATE and LOGIN commands In --debug mode in order to avoid inadvertently receiving credentials in bug reports. --debug can be set twice to spell out these commands in full. --- lib/Net/IMAP/InterIMAP.pm | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index aacc8e7..76135ea 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -436,8 +436,21 @@ sub new($%) { $self->fail("Unsupported authentication mechanism: $mech"); } + my $dbg; delete $self->{password}; # no need to remember passwords + if (($self->{debug} // 0) == 1) { + $dbg = $self->{debug}--; + my $cmd = $command =~ /\A(LOGIN) / ? $1 + : $command =~ /\A(AUTHENTICATE \S+)(?: .*)?\z/ ? $1 + : $self->panic(); + $self->logger('C: xxx ', $cmd, ' [REDACTED]'); + } $self->_send($command, $callback); + if (defined $dbg) { + $self->logger('S: xxx ', $IMAP_text); + $self->{debug} = $dbg; + } + unless ($IMAP_text =~ /\A\Q$IMAP_cond\E \[CAPABILITY /) { # refresh the CAPABILITY list since the previous one had only pre-login capabilities delete $self->{_CAPABILITIES}; @@ -1826,8 +1839,8 @@ sub _cmd_extend($$) { $self->_cmd_extend_($args); } else { - # server supports LITERAL+: flush the command before each - # literal + # server doesn't supports LITERAL+: flush the command before + # each literal my ($offset, $litlen) = (0, 0); while ( (my $idx = index($$args, "\n", $offset+$litlen)) >= 0 ) { my $line = substr($$args, $offset, $idx+1-$offset); -- cgit v1.2.3 From 1dea617bfa23f09f94270125ff51c0b2b96e39c8 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Wed, 6 Nov 2019 03:21:59 +0100 Subject: Allow lowercase SASL mechanisms. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit RFC 2222 sec. 3 says that values are “from 1 to 20 characters in length, consisting of upper-case letters, digits, hyphens, and/or underscores” so we always upper-case the value. --- lib/Net/IMAP/InterIMAP.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 76135ea..afb5694 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -407,8 +407,8 @@ sub new($%) { @caps = $self->capabilities(); } - my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/i ? $1 : undef } @caps); - my $mech = (grep defined, map {my $m = $_; (grep {$m eq $_} @mechs) ? $m : undef} + my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/i ? uc($1) : undef } @caps); + my $mech = (grep defined, map {my $m = uc($_); (grep {$m eq $_} @mechs) ? $m : undef} split(/ /, $self->{auth}))[0]; $self->fail("Failed to choose an authentication mechanism") unless defined $mech; $self->fail("Logins are disabled.") if ($mech eq 'LOGIN' or $mech eq 'PLAIN') and -- cgit v1.2.3 From e764f7517749d8055ba3af8ae00a0c75a3bccaa7 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Wed, 6 Nov 2019 05:33:34 +0100 Subject: Update copyright years. --- lib/Net/IMAP/InterIMAP.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index afb5694..ff10854 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1,6 +1,6 @@ #---------------------------------------------------------------------- # A minimal IMAP4 client for QRESYNC-capable servers -# Copyright © 2015-2018 Guilhem Moulin +# Copyright © 2015-2019 Guilhem Moulin # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by -- cgit v1.2.3 From bf9272b19724c351cd211067afb177c37c87f210 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 7 Nov 2019 03:53:33 +0100 Subject: wibble --- lib/Net/IMAP/InterIMAP.pm | 1 + 1 file changed, 1 insertion(+) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index ff10854..dd4134d 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -520,6 +520,7 @@ sub stats($) { # Destroy a Net::IMAP::InterIMAP object. sub DESTROY($) { + local($., $@, $!, $^E, $?); my $self = shift; $self->{_STATE} = 'LOGOUT'; -- cgit v1.2.3 From 5b122e3a383c8e7603f1fc2322a6fe5298078a65 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 7 Nov 2019 03:58:29 +0100 Subject: libinterimap: Free reference to $self in _start_ssl(). (We don't need the function anymore once the handshake is established). Otherwise the reference count of that IMAP client never gets to 0 before the global destruction phase. For interimap, this causes traffic stats to be printed not by the cleanup() function as intended, but just before the program exits. --- lib/Net/IMAP/InterIMAP.pm | 1 + 1 file changed, 1 insertion(+) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index dd4134d..9c95109 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1690,6 +1690,7 @@ sub _start_ssl($$) { } @$self{qw/_SSL _SSL_CTX/} = ($ssl, $ctx); + undef $self; # the verify callback has reference to $self, free it now } -- cgit v1.2.3 From 6c5f762596af9567afc4691beea212483fa7a07a Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 7 Nov 2019 19:57:34 +0100 Subject: libinterimap: Don't panic at the end of the compressed stream. Cf. Compress::Raw::Zlib's documentation. Z_STREAM_END denotes a successful state. --- lib/Net/IMAP/InterIMAP.pm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 9c95109..2d1f644 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -20,7 +20,7 @@ package Net::IMAP::InterIMAP v0.0.5; use warnings; use strict; -use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; +use Compress::Raw::Zlib qw/Z_OK Z_STREAM_END Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; use Config::Tiny (); use Errno qw/EEXIST EINTR/; use Net::SSLeay 1.73 (); @@ -1723,8 +1723,9 @@ sub _getline($;$) { $self->{_OUTRAWCOUNT} += $n; if (defined (my $i = $self->{_Z_INFLATE})) { - $i->inflate($buf, $self->{_OUTBUF}) == Z_OK or - $self->panic("Inflation failed: ", $i->msg()); + my $r = $i->inflate($buf, $self->{_OUTBUF}); + $self->panic("Inflation failed: $r ", $i->msg()) + unless $r == Z_OK or $r == Z_STREAM_END; } else { $self->{_OUTBUF} = $buf; -- cgit v1.2.3 From a4a371234215a7705f304875cc8af067bf3142af Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 7 Nov 2019 16:42:52 +0100 Subject: Refactor logging logic. Also, introduce new option 'logger-prefix' to determine the prefix of each log line. Closes: #942725. --- lib/Net/IMAP/InterIMAP.pm | 73 ++++++++++++++++++++++++++++++----------------- 1 file changed, 47 insertions(+), 26 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 2d1f644..bb27009 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -17,6 +17,7 @@ #---------------------------------------------------------------------- package Net::IMAP::InterIMAP v0.0.5; +use v5.10.0; use warnings; use strict; @@ -280,7 +281,8 @@ our $IMAP_text; # # - 'name': An optional instance name to include in log messages. # -# - 'logger-fd': An optional filehandle to use for debug output. +# - 'logger-fd': An optional filehandle to use for debug output +# (default: STDERR). # # - 'keepalive': Whether to enable sending of keep-alive messages. # (type=imap or type=imaps). @@ -289,6 +291,7 @@ sub new($%) { my $class = shift; my $self = { @_ }; bless $self, $class; + require 'Time/HiRes.pm' if defined $self->{'logger-fd'}; # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT' # (cf RFC 3501 section 3) @@ -378,11 +381,6 @@ sub new($%) { # are considered. $self->{_MODIFIED} = {}; - if (defined $self->{'logger-fd'} and defined $self->{'logger-fd'}->fileno - and $self->{'logger-fd'}->fileno != fileno STDERR) { - require 'Time/HiRes.pm'; - } - # wait for the greeting my $x = $self->_getline(); $x =~ s/\A\* (OK|PREAUTH) // or $self->panic($x); @@ -539,32 +537,55 @@ sub DESTROY($) { # $self->log($message, [...]) # $self->logger($message, [...]) -# Log a $message. The latter method is used to log in the 'logger-fd', and -# add timestamps. +# Log a $message. The latter method is used to log in the 'logger-fd' +# (and adds timestamps). sub log($@) { my $self = shift; return unless @_; - $self->logger(@_) if defined $self->{'logger-fd'} and defined $self->{'logger-fd'}->fileno - and $self->{'logger-fd'}->fileno != fileno STDERR; - my $prefix = $self->{name} // ''; - $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; - $prefix .= ': ' unless $prefix eq ''; - print STDERR $prefix, @_, "\n"; + my $prefix = _logger_prefix($self); + if (defined (my $fd = $self->{'logger-fd'})) { + say $fd _date(), " ", $prefix, @_; + } + say STDERR $prefix, @_; } sub logger($@) { my $self = shift; - return unless @_ and defined $self->{'logger-fd'}; - my $prefix = ''; - if (defined $self->{'logger-fd'}->fileno and defined $self->{'logger-fd'}->fileno - and $self->{'logger-fd'}->fileno != fileno STDERR) { - my ($s, $us) = Time::HiRes::gettimeofday(); - $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us"; - $prefix .= ' ' if defined $self->{name} or $self->{_STATE} eq 'SELECTED'; - } - $prefix .= $self->{name} if defined $self->{name}; - $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; - $prefix .= ': ' unless $prefix eq ''; - $self->{'logger-fd'}->say($prefix, @_); + return unless @_; + my $prefix = _logger_prefix($self); + if (defined (my $fd = $self->{'logger-fd'})) { + say $fd _date(), " ", $prefix, @_; + } else { + say STDERR $prefix, @_; + } +} +sub _date() { + my ($s, $us) = Time::HiRes::gettimeofday(); + my $t = POSIX::strftime("%b %e %H:%M:%S", localtime($s)); + return "$t.$us"; # millisecond precision +} + +# $self->_logger_prefix() +# Format a prefix for logging with printf(3)-like sequences: +# %n: the object name +# %m: mailbox, either explicit named or selected +sub _logger_prefix($) { + my $self = shift; + my $format = $self->{'logger-prefix'} // return ""; + + my %seq = ( "%" => "%", m => $self->{mailbox}, n => $self->{name} ); + $seq{m} //= $self->{_SELECTED} // die + if defined $self->{_STATE} and $self->{_STATE} eq 'SELECTED'; + + do {} while + # rewrite conditionals (loop because of nesting) + $format =~ s#%\? ([[:alpha:]]) \? + ( (?: (?> (?: [^%&?\\] | %[^?] | \\[&?\\] )+ ) | (?R) )* ) + (?: \& ( (?: (?> (?: [^%&?\\] | %[^?] | \\[&?\\] )+ ) | (?R) )*) )? + \?# ($seq{$1} // "") ne "" ? $2 : ($3 // "") #agex; + + $format =~ s#\\([&?\\])#$1#g; # unescape remaining '&', '?' and '\' + $format =~ s#%([%mn])# $seq{$1} #ge; + return $format; } -- cgit v1.2.3