#---------------------------------------------------------------------- # A minimal IMAP4 client for QRESYNC-capable servers # Copyright © 2015-2018 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 # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . #---------------------------------------------------------------------- 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 Config::Tiny (); use Errno qw/EEXIST EINTR/; use Net::SSLeay 1.73 (); use List::Util qw/all first/; use POSIX ':signal_h'; use Socket qw/SOCK_STREAM SOCK_RAW SOCK_CLOEXEC IPPROTO_TCP SHUT_RDWR AF_UNIX AF_INET AF_INET6 PF_UNSPEC :addrinfo/; use Exporter 'import'; BEGIN { Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); our @EXPORT_OK = qw/xdg_basedir read_config compact_set $IMAP_text $IMAP_cond slurp is_dirty has_new_mails/; } # Regexes for RFC 3501's 'ATOM-CHAR', 'ASTRING-CHAR', 'list-char' and 'TEXT-CHAR'. my $RE_ATOM_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5E-\x7A\x7C-\x7E]/; my $RE_ASTRING_CHAR = qr/[\x21\x23\x24\x26\x27\x2B-\x5B\x5D-\x7A\x7C-\x7E]/; my $RE_LIST_CHAR = qr/[\x21\x23-\x27\x2A\x2B-\x5B\x5D-\x7A\x7C-\x7E]/; my $RE_TEXT_CHAR = qr/[\x01-\x09\x0B\x0C\x0E-\x7F]/; my $RE_SSL_PROTO = qr/(?:SSLv[23]|TLSv1|TLSv1\.[0-3])/; # Map each option to a regexp validating its values. my %OPTIONS = ( host => qr/\A(\P{Control}+)\z/, port => qr/\A(\P{Control}+)\z/, proxy => qr/\A(\P{Control}+)\z/, type => qr/\A(imaps?|tunnel)\z/, STARTTLS => qr/\A(YES|NO)\z/i, username => qr/\A([\x01-\x7F]+)\z/, password => qr/\A([\x01-\x7F]+)\z/, auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/, command => qr/\A(\P{Control}+)\z/, 'null-stderr' => qr/\A(YES|NO)\z/i, compress => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/, SSL_protocols => qr/\A(!?$RE_SSL_PROTO(?: !?$RE_SSL_PROTO)*)\z/, SSL_fingerprint => qr/\A((?:[A-Za-z0-9]+\$)?\p{AHex}+)\z/, SSL_cipherlist => qr/\A(\P{Control}+)\z/, SSL_verify => qr/\A(YES|NO)\z/i, SSL_CApath => qr/\A(\P{Control}+)\z/, SSL_CAfile => qr/\A(\P{Control}+)\z/, ); # Use the same buffer size as Net::SSLeay::read(), to ensure there is # never any pending data left in the current TLS record my $BUFSIZE = 32768; my $CRLF = "\x0D\x0A"; ############################################################################# # Utilities # xdg_basedir($xdg_variable, $default, $subdir, $path) # Return $path if $path is absolute. Otherwise, return # "$ENV{$xdg_variable}/$subdir/$path" (resp. "~/$default/$subdir/path" # if the "$xdg_variable" environment variable is not set). # An error is raised if "$ENV{$xdg_variable}" (resp. "~/$default") is # not an existing absolute directory. # If "$ENV{$xdg_variable}/$subdir" doesn't exist, it is created with # mode 0700. sub xdg_basedir($$$$) { my ($xdg_variable, $default, $subdir, $path) = @_; $path =~ /\A(\p{Print}+)\z/ or die "Insecure $path"; $path = $1; return $path if $path =~ /\A\//; my $basedir = $ENV{$xdg_variable}; unless (defined $basedir) { my @getent = getpwuid($>); $basedir = $getent[7] ."/". $default; } die "No such directory: ", $basedir unless -d $basedir; $basedir .= "/".$subdir; $basedir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $basedir"; $basedir = $1; unless (mkdir ($basedir, 0700)) { die "Couldn't create $basedir: $!\n" unless $! == EEXIST; } return $basedir ."/". $path; } # read_config($conffile, $sections, %opts) # Read $conffile's default section, then each section in the array # reference $section (which takes precedence). %opts extends %OPTIONS # and maps each option to a regexp validating its values. sub read_config($$%) { my $conffile = shift; my $sections = shift; my %opts = (%OPTIONS, @_); die "No such config file $conffile\n" unless defined $conffile and -f $conffile and -r $conffile; my $h = Config::Tiny::->read($conffile); my %configs; foreach my $section (@$sections) { my $conf = defined $h->{_} ? { %{$h->{_}} } : {}; # default section $configs{$section} = $conf; if ($section ne '_') { die "No such section $section\n" unless defined $h->{$section}; $conf->{$_} = $h->{$section}->{$_} foreach keys %{$h->{$section}}; } # default values $conf->{type} //= 'imaps'; $conf->{host} //= 'localhost'; $conf->{port} //= $conf->{type} eq 'imaps' ? 993 : $conf->{type} eq 'imap' ? 143 : undef; $conf->{auth} //= 'PLAIN LOGIN'; $conf->{STARTTLS} //= 'YES'; # untaint and validate the config foreach my $k (keys %$conf) { die "Invalid option $k\n" unless defined $opts{$k}; next unless defined $conf->{$k}; die "Invalid option $k = $conf->{$k}\n" unless $conf->{$k} =~ $opts{$k}; $conf->{$k} = $opts{$k} ne qr/\A(YES|NO)\z/i ? $1 : uc $1 eq 'YES' ? 1 : 0; } } return \%configs; } # compact_set(@set) # compact_list(@set) # Compact the UID or sequence number set @set, which must be # non-empty and may not contain '*'. # compact_set sorts the input UID list and removes duplicates, while # compact_list doesn't. sub compact_set(@) { my @set = sort {$a <=> $b} @_; my $min = my $max = shift @set // die 'Empty range'; my $set; while (@set) { my $k = shift @set; if ($k < $max) { die "Non-sorted range: $k < $max"; # sanity check } elsif ($k == $max) { # skip duplicates } elsif ($k == $max + 1) { $max++; } else { $set .= ',' if defined $set; $set .= $min == $max ? $min : "$min:$max"; $min = $max = $k; } } $set .= ',' if defined $set; $set .= $min == $max ? $min : "$min:$max"; return $set; } sub compact_list(@) { my $min = my $max = shift // die 'Empty range'; my ($set, $dir); while (@_) { my $k = shift; $dir //= $k < $max ? -1 : 1; if ($k != $max and $k == $max + $dir) { $max += $dir; } else { $set .= ',' if defined $set; $set .= $min == $max ? $min : "$min:$max"; $min = $max = $k; undef $dir; } } $set .= ',' if defined $set; $set .= $min == $max ? $min : "$min:$max"; return $set; } # in_set($x, $set) # Return true if the UID or sequence number $x belongs to the set $set. # /!\ The highest number in the mailbox, "*" should not appear by # itself (other than in a range). sub in_set($$) { my ($x, $set) = @_; foreach my $r (split /,/, $set) { if ($r =~ /\A([0-9]+)\z/) { return 1 if $x == $1; } elsif ($r eq '*' or $r eq '*:*') { warn "Assuming $x belongs to set $set! (Dunno what \"*\" means.)"; return 1; } elsif ($r =~ /\A([0-9]+):\*\z/ or $r =~ /\A\*:([0-9]+)\z/) { return 1 if $1 <= $x; } elsif ($r =~ /\A([0-9]+):([0-9]+)\z/) { my ($min,$max) = $1 < $2 ? ($1,$2) : ($2,$1); return 1 if $min <= $x and $x <= $max; } } return 0; } # quote($str) # Quote the given string if needed, or make it a (synchronizing) # literal. The literals will later be made non-synchronizing if the # server is LITERAL+-capable (RFC 2088). sub quote($) { my $str = shift; if ($str =~ qr/\A$RE_ASTRING_CHAR+\z/) { return $str; } elsif ($str =~ qr/\A$RE_TEXT_CHAR*\z/) { $str =~ s/([\x22\x5C])/\\$1/g; return "\"$str\""; } else { # we'll later replace the non-synchronizing literal with a # synchronizing one if need be return "{".length($str)."+}$CRLF".$str; } } ############################################################################# # Public interface # /!\ While this module can be used with non QRESYNC-capable (or non # QRESYNC-enabled) servers, there is no internal cache mapping sequence # numbers to UIDs, so EXPUNGE responses are ignored. # The IMAP authentication ('OK'/'PREAUTH'), bye ('BYE') or status # ('OK'/'NO'/'BAD') condition for the last command issued. our $IMAP_cond; # The response text for the last command issued (prefixed with the status # condition but without the tag). our $IMAP_text; # Create a new Net::IMAP::InterIMAP object. Connect to the server, # upgrade to a secure connection (STARTTLS), LOGIN/AUTHENTICATE if needed, and # update the CAPABILITY list. # In addition to the %OPTIONS above, valid parameters include: # # - 'debug': Enable debug messages. # # - 'enable': An extension or array reference of extensions to ENABLE # (RFC 5161) after entering AUTH state. Croak if the server did not # advertise "ENABLE" in its CAPABILITY list or does not reply with # an untagged ENABLED response with all the given extensions. # # - 'name': An optional instance name to include in log messages. # # - '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 = { @_ }; bless $self, $class; # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT' # (cf RFC 3501 section 3) $self->{_STATE} = ''; # in/out buffer counts and output stream $self->{_INCOUNT} = $self->{_INRAWCOUNT} = 0; $self->{_OUTCOUNT} = $self->{_OUTRAWCOUNT} = 0; $self->{_OUTBUF} = $self->{_INBUF} = undef; $self->{_LITPLUS} = ''; if ($self->{type} eq 'tunnel') { my $command = $self->{command} // $self->fail("Missing tunnel command"); socketpair($self->{S}, my $s, AF_UNIX, SOCK_STREAM|SOCK_CLOEXEC, PF_UNSPEC) or $self->panic("socketpair: $!"); my $pid = fork // $self->panic("fork: $!"); unless ($pid) { # children close($self->{S}) or $self->panic("Can't close: $!"); open STDIN, '<&', $s or $self->panic("Can't dup: $!"); open STDOUT, '>&', $s or $self->panic("Can't dup: $!"); my $stderr2; if ($self->{'null-stderr'} // 0) { open $stderr2, '>&', *STDERR; open STDERR, '>', '/dev/null' or $self->panic("Can't open /dev/null: $!"); } my $sigset = POSIX::SigSet::->new(SIGINT); my $oldsigset = POSIX::SigSet::->new(); sigprocmask(SIG_BLOCK, $sigset, $oldsigset) // $self->panic("Can't block SIGINT: $!"); unless (exec $command) { my $err = $!; if (defined $stderr2) { close STDERR; open STDERR, '>&', $stderr2; } $self->panic("Can't exec: $err"); } } # parent close($s) or $self->panic("Can't close: $!"); } else { foreach (qw/host port/) { $self->fail("Missing option $_") unless defined $self->{$_}; } $self->{S} = defined $self->{proxy} ? $self->_proxify(@$self{qw/proxy host port/}) : $self->_tcp_connect(@$self{qw/host port/}); if (defined $self->{keepalive}) { setsockopt($self->{S}, Socket::SOL_SOCKET, Socket::SO_KEEPALIVE, 1) or $self->fail("Can't setsockopt SO_KEEPALIVE: $!"); setsockopt($self->{S}, Socket::IPPROTO_TCP, Socket::TCP_KEEPIDLE, 60) or $self->fail("Can't setsockopt TCP_KEEPIDLE: $!"); } } binmode($self->{S}) // $self->panic("binmode: $!"); $self->_start_ssl($self->{S}) if $self->{type} eq 'imaps'; # command counter $self->{_TAG} = 0; # internal cache, constantly updated to reflect the current server # state for each mailbox $self->{_CACHE} = {}; # persistent cache, describing the last clean (synced) state $self->{_PCACHE} = {}; # list of UIDs for which the server a VANISHED or VANISHED (EARLIER) # response. /!\ requires a QRESYNC-capable server! # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT} # are considered. $self->{_VANISHED} = []; # hash UID => [ MODSEQ, FLAGS ] for which the server a FETCH # response with the FLAGS attribute. The \Recent flag is always # omitted from the FLAG list. MODSEQ is always present, and the # value [ MODSEQ, FLAGS ] is updated if another FETCH response with # a higher MODSEQ is received. If FLAGS is undefined, then the FLAG # list of the message is considered unknown and should be retrieved # manually. # Only notifications with UID < $self->{_PCACHE}->{$mailbox}->{UIDNEXT} # and with MODSEQ => $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} # 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); $IMAP_cond = $1; $IMAP_text = $1.' '.$x; # try to update the cache (eg, capabilities) $self->_resp_text($x); if ($IMAP_cond eq 'OK') { # login required $self->{_STATE} = 'UNAUTH'; my @caps = $self->capabilities(); if ($self->{type} eq 'imap' and $self->{STARTTLS}) { # RFC 2595 section 5.1 $self->fail("Server did not advertise STARTTLS capability.") unless grep {$_ eq 'STARTTLS'} @caps; $self->_start_ssl($self->{S}) if $self->{type} eq 'imaps'; # refresh the previous CAPABILITY list since the previous one could have been spoofed delete $self->{_CAPABILITIES}; @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} 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 grep {$_ eq 'LOGINDISABLED'} @caps; my ($command, $callback); my ($username, $password) = @$self{qw/username password/}; if ($mech eq 'LOGIN') { $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/; $command = join ' ', 'LOGIN', quote($username), quote($password); } elsif ($mech eq 'PLAIN') { require 'MIME/Base64.pm'; $self->fail("Missing option $_") foreach grep {!defined $self->{$_}} qw/username password/; my $credentials = MIME::Base64::encode_base64("\x00".$username."\x00".$password, ''); $command = "AUTHENTICATE $mech"; if ($self->_capable('SASL-IR')) { # RFC 4959 SASL-IR $command .= " $credentials"; } else { $callback = sub($) {return $credentials}; } } else { $self->fail("Unsupported authentication mechanism: $mech"); } delete $self->{password}; # no need to remember passwords $self->_send($command, $callback); 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}; $self->capabilities(); } } $self->{_STATE} = 'AUTH'; # Don't send the COMPRESS command before STARTTLS or AUTH, as per RFC 4978 if ($self->{compress} // 1 and my @algos = grep defined, map { /^COMPRESS=(.+)/i ? uc $1 : undef } @{$self->{_CAPABILITIES}}) { my @supported = qw/DEFLATE/; # supported compression algorithms my $algo = first { my $x = $_; grep {$_ eq $x} @algos } @supported; if (!defined $algo) { $self->warn("Couldn't find a suitable compression algorithm. Not enabling compression."); } else { my ($d, $i); my $r = $self->_send("COMPRESS $algo"); unless ($r eq 'NO' and $IMAP_text =~ /\ANO \[COMPRESSIONACTIVE\] /) { $self->panic($IMAP_text) unless $r eq 'OK'; if ($algo eq 'DEFLATE') { my %args = ( -WindowBits => 0 - MAX_WBITS, -Bufsize => $BUFSIZE ); $self->{_Z_DEFLATE} = Compress::Raw::Zlib::Deflate::->new(%args, -AppendOutput => 1) // $self->panic("Can't create deflation stream"); $self->{_Z_INFLATE} = Compress::Raw::Zlib::Inflate::->new(%args) // $self->panic("Can't create inflation stream"); } else { $self->fail("Unsupported compression algorithm: $algo"); } } } } my @extensions = !defined $self->{enable} ? () : ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}} : ($self->{enable}); if (@extensions) { $self->fail("Server did not advertise ENABLE (RFC 5161) capability.") unless $self->_capable('ENABLE'); $self->_send('ENABLE '.join(' ',@extensions)); my @enabled = @{$self->{_ENABLED} // []}; $self->fail("Couldn't ENABLE $_") foreach grep {my $e = $_; !grep {uc $e eq uc $_} @enabled} @extensions; } return $self; } # Print traffic statistics sub stats($) { my $self = shift; my $msg = 'IMAP traffic (bytes):'; $msg .= ' recv '._kibi($self->{_OUTCOUNT}); $msg .= ' (compr. '._kibi($self->{_OUTRAWCOUNT}). ', factor '.sprintf('%.2f', $self->{_OUTRAWCOUNT}/$self->{_OUTCOUNT}).')' if exists $self->{_Z_DEFLATE} and $self->{_OUTCOUNT} > 0; $msg .= ' sent '._kibi($self->{_INCOUNT}); $msg .= ' (compr. '._kibi($self->{_INRAWCOUNT}). ', factor '.sprintf('%.2f', $self->{_INRAWCOUNT}/$self->{_INCOUNT}).')' if exists $self->{_Z_DEFLATE} and $self->{_INCOUNT} > 0; $self->log($msg); } # Destroy a Net::IMAP::InterIMAP object. sub DESTROY($) { my $self = shift; $self->{_STATE} = 'LOGOUT'; Net::SSLeay::free($self->{_SSL}) if defined $self->{_SSL}; Net::SSLeay::CTX_free($self->{_SSL_CTX}) if defined $self->{_SSL_CTX}; if (defined (my $s = $self->{S})) { # for type=tunnel we assume the child won't linger around once # we close its standard input and output. shutdown($s, SHUT_RDWR); $s->close() if $s->opened(); } $self->stats() unless $self->{quiet}; } # $self->log($message, [...]) # $self->logger($message, [...]) # Log a $message. The latter method is used to log in the 'logger-fd', and # add 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"; } 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, @_); } # $self->warn([$type,] $warning) # Log a $warning. sub warn($$;$) { my ($self, $msg, $t) = @_; $msg = defined $t ? "$msg WARNING: $t" : "WARNING: $msg"; $self->log($msg); } # $self->fail([$type,] $error) # Log an $error and exit with return value 1. sub fail($$;$) { my ($self, $msg, $t) = @_; $msg = defined $t ? "$msg ERROR: $t" : "ERROR: $msg"; $self->log($msg); exit 1; } # $self->panic($error, [...]) # Log a fatal $error including the position of the caller, and exit # with return value 255. sub panic($@) { my $self = shift; my @loc = caller; my $msg = "PANIC at line $loc[2] in $loc[1]"; $msg .= ': ' if @_; $self->log($msg, @_); exit 255; } # $self->capabilities() # Return the capability list of the IMAP4 server. The list is cached, # and a CAPABILITY command is only issued if the cache is empty. sub capabilities($) { my $self = shift; $self->_send('CAPABILITY') unless defined $self->{_CAPABILITIES} and @{$self->{_CAPABILITIES}}; $self->fail("Missing IMAP4rev1 CAPABILITY. Not an IMAP4 server?") unless $self->_capable('IMAP4rev1'); return @{$self->{_CAPABILITIES}}; } # $self->incapable(@capabilities) # In list context, return the list capabilties from @capabilities # which were NOT advertised by the server. In scalar context, return # the length of said list. sub incapable($@) { my ($self, @caps) = @_; my @mycaps = $self->capabilities(); grep {my $cap = uc $_; !grep {$cap eq uc $_} @mycaps} @caps; } # $self->search($criterion) # Issue an UID SEARCH command with the given $criterion. For the "normal" # UID SEARCH command from RFC 3501, return the list of matching UIDs; # for the extended UID SEARCH command from RFC 4731 (ensuring ESEARCH # capability is the caller's responsibility), return an optional "UID" # indicator followed by a hash containing search data pairs. sub search($$) { my ($self, $crit) = @_; my @res; $self->_send('UID SEARCH '.$crit, sub(@) {@res = @_}); return @res } # $self->select($mailbox, [$seqs, $UIDs]) # $self->examine($mailbox, [$seqs, $UIDs]) # Issue a SELECT or EXAMINE command for the $mailbox. Upon success, # change the state to SELECTED, otherwise go back to AUTH. # The optional $seqs and $UIDs are used as Message Sequence Match # Data for the QRESYNC parameter to the SELECT command. sub select($$;$$) { my $self = shift; my $mailbox = shift; $self->_select_or_examine('SELECT', $mailbox, @_); } sub examine($$;$$) { my $self = shift; my $mailbox = shift; $self->_select_or_examine('EXAMINE', $mailbox, @_); } # $self->unselect() # Issue an UNSELECT command (cf. RFC 3691). Upon success, change the # state to AUTH. sub unselect($) { my $self = shift; $self->_send('UNSELECT'); $self->{_STATE} = 'AUTH'; delete $self->{_SELECTED}; # it is safe to wipe cached VANISHED responses or FLAG updates, # because interesting stuff must have made the mailbox dirty so # we'll get back to it $self->{_VANISHED} = []; $self->{_MODIFIED} = {}; $self->{_NEW} = 0; } # $self->logout() # Issue a LOGOUT command. Change the state to LOGOUT. sub logout($) { my $self = shift; # don't bother if the connection is already closed $self->_send('LOGOUT') if $self->{S}->opened(); $self->{_STATE} = 'LOGOUT'; undef $self; } # $self->noop() # Issue a NOOP command. sub noop($) { shift->_send('NOOP'); } # $self->create($mailbox, [$try]) # $self->delete($mailbox, [$try]) # CREATE or DELETE $mailbox. # If try is set, print a warning but don't crash if the command fails. sub create($$;$) { my ($self, $mailbox, $try) = @_; my $r = $self->_send("CREATE ".quote($mailbox)); if ($IMAP_cond eq 'OK') { $self->log("Created mailbox ".$mailbox) unless $self->{quiet}; } else { my $msg = "Couldn't create mailbox ".$mailbox.': '.$IMAP_text; $try ? $self->warn($msg) : $self->fail($msg); } return $r; } sub delete($$;$) { my ($self, $mailbox, $try) = @_; my $r = $self->_send("DELETE ".quote($mailbox)); delete $self->{_CACHE}->{$mailbox}; delete $self->{_PCACHE}->{$mailbox}; if ($IMAP_cond eq 'OK') { $self->log("Deleted mailbox ".$mailbox) unless $self->{quiet}; } else { my $msg = "Couldn't delete mailbox ".$mailbox.': '.$IMAP_text; $try ? $self->warn($msg) : $self->fail($msg); } return $r; } # $self->rename($oldname, $newname, [$try]) # RENAME the mailbox $oldname to $newname. # If $try is set, print a warning but don't crash if the command fails. # /!\ Requires a LIST command to be issued to determine the hierarchy # delimiter and the mailbox attributes for the original name. sub rename($$$;$) { my ($self, $from, $to, $try) = @_; my ($delim, @attrs); if ($self->{_CACHE}->{$from}) { $delim = $self->{_CACHE}->{$from}->{DELIMITER}; @attrs = @{$self->{_CACHE}->{$from}->{LIST_ATTRIBUTES} // []}; } my $r = $self->_send("RENAME ".quote($from).' '.quote($to)); $self->{_CACHE}->{$to} = delete $self->{_CACHE}->{$from} if exists $self->{_CACHE}->{$from}; $self->{_PCACHE}->{$to} = delete $self->{_PCACHE}->{$from} if exists $self->{_PCACHE}->{$from}; if (defined $delim and !grep {lc $_ eq lc '\NoInferiors' or lc $_ eq lc '\HasNoChildren'} @attrs) { # on non-flat mailboxes, move children as well (cf 3501) foreach my $c1 (grep /\A\Q$from$delim\E/, keys %{$self->{_CACHE}}) { my $c2 = $c1 =~ s/\A\Q$from$delim\E/$to$delim/r; $self->{_CACHE}->{$c2} = delete $self->{_CACHE}->{$c1} if exists $self->{_CACHE}->{$c1}; $self->{_PCACHE}->{$c2} = delete $self->{_PCACHE}->{$c1} if exists $self->{_PCACHE}->{$c1}; } } if ($IMAP_cond eq 'OK') { $self->log("Renamed mailbox ".$from.' to '.$to) unless $self->{quiet}; } else { my $msg = "Couldn't rename mailbox ".$from.': '.$IMAP_text; $try ? $self->warn($msg) : $self->fail($msg); } return $r; } # $self->subscribe($mailbox, [$try]) # $self->unsubscribe($mailbox, [$try]) # SUBSCRIBE or UNSUBSCRIBE $mailbox. # If $try is set, print a warning but don't crash if the command fails. sub subscribe($$;$) { my ($self, $mailbox, $try) = @_; $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive my $r = $self->_send("SUBSCRIBE ".quote($mailbox)); if ($IMAP_cond eq 'OK') { $self->log("Subscribe to ".$mailbox) unless $self->{quiet}; } else { my $msg = "Couldn't subscribe to ".$mailbox.': '.$IMAP_text; $try ? $self->warn($msg) : $self->fail($msg); } return $r; } sub unsubscribe($$;$) { my ($self, $mailbox, $try) = @_; $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive my $r = $self->_send("UNSUBSCRIBE ".quote($mailbox)); if ($IMAP_cond eq 'OK') { $self->log("Unsubscribe to ".$mailbox) unless $self->{quiet}; } else { my $msg = "Couldn't unsubscribe to ".$mailbox.': '.$IMAP_text; $try ? $self->warn($msg) : $self->fail($msg); } return $r; } # $self->list($criterion, @parameters) # Issue a LIST command with the given $criterion and @parameters. # Return a pair where the first component is a hash reference of # matching mailboxes and their flags, and the second component is a # hash reference of matching mailboxes and their hierarchy delimiter # (or undef for flat mailboxes). sub list($$@) { my $self = shift; my $crit = shift; my %mailboxes; my %delims; $self->_send( "LIST ".$crit.(@_ ? (' RETURN ('.join(' ', @_).')') : ''), sub($$@) {my $name = shift; $delims{$name} = shift; $mailboxes{$name} = \@_;} ); return (\%mailboxes, \%delims); } # $self->remove_message($uid, [...]) # Remove the given $uid list. Croak if the server did not advertise # "UIDPLUS" (RFC 4315) in its CAPABILITY list. # Successfully EXPUNGEd UIDs are removed from the pending VANISHED and # MODIFIED lists. # Return the list of UIDs that couldn't be EXPUNGEd. sub remove_message($@) { my $self = shift; my @set = @_; $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") unless $self->_capable('UIDPLUS'); my $set = compact_set(@set); $self->_send("UID STORE $set +FLAGS.SILENT (\\Deleted)"); $self->_send("UID EXPUNGE $set"); # RFC 4315 UIDPLUS my %vanished = map {$_ => 1} @{$self->{_VANISHED}}; my (@failed, @expunged); foreach my $uid (@set) { if (exists $vanished{$uid}) { push @expunged, $uid } else { push @failed, $uid; } } # ignore succesfully EXPUNGEd messages delete @vanished{@expunged}; delete @{$self->{_MODIFIED}}{@expunged}; $self->{_VANISHED} = [ keys %vanished ]; $self->log("Removed ".($#expunged+1)." UID(s) ". compact_set(@expunged)) if @expunged and !$self->{quiet}; $self->warn("Couldn't UID EXPUNGE ".compact_set(@failed)) if @failed; return @failed; } # $self->append($mailbox, $mail, [...]) # 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 # 'UID', '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, in the order # they were APPENDed. sub append($$@) { my $self = shift; my $mailbox = shift; return unless @_; $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") unless $self->_capable('UIDPLUS'); $self->fail("Server did not advertise MULTIAPPEND (RFC 3502) capability.") unless $#_ == 0 or $self->_capable('MULTIAPPEND'); # dump the cache before issuing the command if we're appending to the current mailbox my ($UIDNEXT, $EXISTS, $cache, %vanished); $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) { $cache = $self->{_CACHE}->{$mailbox}; $UIDNEXT = $cache->{UIDNEXT} // $self->panic(); $EXISTS = $cache->{EXISTS} // $self->panic(); %vanished = map {$_ => 1} @{$self->{_VANISHED}}; } my $tag = $self->_cmd_init('APPEND '.quote($mailbox)); foreach my $mail (@_) { my $str = ' '; $str .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') ' if defined $mail->{FLAGS}; $str .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE}; $self->_cmd_extend(\$str); $self->_cmd_extend_lit($mail->{RFC822} // $self->panic("Missing message body in APPEND")); } $self->_cmd_flush(); $self->_recv($tag); $IMAP_text =~ /\A\Q$IMAP_cond\E \[APPENDUID ([0-9]+) ([0-9:,]+)\] / or $self->panic($IMAP_text); my ($uidvalidity, $uidset) = ($1, $2); $self->_update_cache_for($mailbox, UIDVALIDITY => $uidvalidity); my @uids; foreach (split /,/, $uidset) { if (/\A([0-9]+)\z/) { $UIDNEXT = $1 + 1 if defined $UIDNEXT and $UIDNEXT <= $1; push @uids, $1; } elsif (/\A([0-9]+):([0-9]+)\z/) { my ($min, $max) = $1 <= $2 ? ($1,$2) : ($2,$1); push @uids, ($min .. $max); $UIDNEXT = $max + 1 if defined $UIDNEXT and $UIDNEXT <= $max; } else { $self->panic($_); } } $self->fail("$uidset contains ".scalar(@uids)." elements while ".($#_+1)." messages were appended.") unless $#uids == $#_; # if $mailbox is the current mailbox we need to update the cache if (defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}) { # EXISTS responses SHOULD be sent by the server (per RFC3501), but it's not required my %vanished2 = map {$_ => 1} @{$self->{_VANISHED}}; delete $vanished2{$_} foreach keys %vanished; my $VANISHED = scalar(keys %vanished2); # number of messages VANISHED meanwhile $cache->{EXISTS} += $#_+1 if defined $cache->{EXISTS} and $cache->{EXISTS} + $VANISHED == $EXISTS; $cache->{UIDNEXT} = $UIDNEXT if ($cache->{UIDNEXT} // 1) < $UIDNEXT; } unless ($self->{quiet}) { my $msg = "Added ".($#_+1)." UID(s) "; $msg .= "to $mailbox " unless defined $self->{_SELECTED} and $mailbox eq $self->{_SELECTED}; if (defined $self->{name} and all {defined $_->{UID}} @_) { $msg .= $self->{name} eq 'local' ? (compact_list(@uids) .' <- '. compact_list(map {$_->{UID}} @_)) : (compact_list(map {$_->{UID}} @_) .' -> '. compact_list(@uids)); } else { $msg .= compact_list(@uids); } $self->log($msg); } return @uids; } # $self->fetch($set, $flags, [$callback]) # Issue an UID FETCH command with the given UID $set, $flags, and # optional $callback. sub fetch($$$;&) { my ($self, $set, $flags, $callback) = @_; $self->_send("UID FETCH $set $flags", $callback); } # $self->notify($arg, %specifications) # Issue a NOTIFY command with the given $arg ("SET", "SET STATUS" or # "NONE") and mailbox %specifications (cf RFC 5465 section 6) to be # monitored. Croak if the server did not advertise "NOTIFY" (RFC # 5465) in its CAPABILITY list. sub notify($$@) { my $self = shift; $self->fail("Server did not advertise NOTIFY (RFC 5465) capability.") unless $self->_capable('NOTIFY'); my $command = 'NOTIFY '.shift; while (@_) { $command .= " (".shift." (".join(' ', @{shift()})."))"; } $self->_send($command); } # slurp($imap, $timeout, $stopwhen) # Keep reading untagged responses from the @$imap servers until the # $stopwhen condition becomes true (then return true), or until the # $timeout expires (then return false). # This is mostly useful when waiting for notifications while no # command is progress, cf. RFC 2177 (IDLE) or RFC 5465 (NOTIFY). sub slurp($$$) { my ($selfs, $timeout, $stopwhen) = @_; my $aborted = 0; my $rin = ''; vec($rin, fileno($_->{S}), 1) = 1 foreach @$selfs; while (1) { # first, consider only unprocessed data without our own output # buffer, or within the current TLS record: these would cause # select(2) to block/timeout due to the raw socket not being # ready. my @ready = grep { (defined $_->{_OUTBUF} and $_->{_OUTBUF} ne '') or (defined $_->{_SSL} and Net::SSLeay::pending($_->{_SSL}) > 0) } @$selfs; unless (@ready) { my ($r, $timeleft) = CORE::select(my $rout = $rin, undef, undef, $timeout); next if $r == -1 and $! == EINTR; # select(2) was interrupted die "select: $!" if $r == -1; return $aborted if $r == 0; # nothing more to read (timeout reached) @ready = grep {vec($rout, fileno($_->{S}), 1)} @$selfs; $timeout = $timeleft if $timeout > 0; } foreach my $imap (@ready) { my $x = $imap->_getline(); $imap->_resp($x, sub($;$$) { if ($stopwhen->($imap, @_)) { $aborted = 1; $timeout = 0; # keep reading the handles while there is pending data } }, 'slurp'); } } return $aborted; } # $self->idle($timeout, $stopwhen) # Enter IDLE (RFC 2177) for $timout seconds (by default 29 mins), or # when the callback $stopwhen returns true. # Return true if the callback returned true (either aborting IDLE, or # after the $timeout) and false otherwise. sub idle($$$) { my ($self, $timeout, $stopwhen) = @_; my $tag = $self->idle_start($timeout); my $r = slurp([$self], $timeout // 1740, $stopwhen); # 29 mins $r += $self->idle_stop($tag, $stopwhen); return $r; } # $self->idle_start() # Enter IDLE (RFC 2177). # Return the command tag. sub idle_start($) { my $self = shift; $self->fail("Server did not advertise IDLE (RFC 2177) capability.") unless $self->_capable('IDLE'); my $tag = $self->_cmd_init('IDLE'); $self->_cmd_flush(); return $tag; } # $self->idle_stop($tag, $callback) # Stop a running IDLE (RFC 2177) command $tag. # Returns the number of untagged responses received between the DONE # the tagged response that are satisfying $callback. sub idle_stop($$$) { my ($self, $tag, $callback) = @_; my $r = 0; # done idling $self->_cmd_extend('DONE'); $self->_cmd_flush(); # run the callback again to update the return value if we received # untagged responses between the DONE and the tagged response $self->_recv($tag, sub($;$$) { $r++ if $callback->($self, @_) }, 'slurp'); return $r; } # $self->set_cache($mailbox, STATE) # Initialize or update the persistent cache, that is, associate a # known $mailbox with the last known (synced) state: # * UIDVALIDITY # * UIDNEXT: Any message the UID of which is at least UIDNEXT is # considered new and must be downloaded. (If 0 or missing, all # messages in $mailbox are considered new.) Note that while all # UIDs in the map are panic(); $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive my $cache = $self->{_PCACHE}->{$mailbox} //= {}; my %status = @_; while (my ($k, $v) = each %status) { if ($k eq 'UIDVALIDITY') { # try to detect UIDVALIDITY changes early (before starting the sync) $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ". "Need to invalidate the UID cache.") if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v; } $cache->{$k} = $v; } $self->logger("Update last clean state for $mailbox: ". '('.join(' ', map {"$_ $cache->{$_}"} grep {defined $cache->{$_}} keys %$cache).')') if $self->{debug}; } # $self->uidvalidity([$mailbox]) # Return the UIDVALIDITY for $mailbox, or hash mapping each mailbox to # its UIDVALIDITY if $mailbox is omitted. sub uidvalidity($;$) { my $self = shift; my $mailbox = shift; if (defined $mailbox) { $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive my $cache = $self->{_CACHE}->{$mailbox} // return; return $cache->{UIDVALIDITY}; } else { my %uidvalidity; while (my ($mbx,$cache) = each %{$self->{_CACHE}}) { $uidvalidity{$mbx} = $cache->{UIDVALIDITY} if ($cache->{UIDVALIDITY} // 0) > 0; } return %uidvalidity; } } # $self->get_cache(@attributes) # Return the persistent cache for the mailbox currently selected. If # some @attributes are given, return the list of values corresponding # to these attributes. # /!\ Should only be called right after pull_updates! # Croak if there are unprocessed VANISHED responses or FLAG updates. sub get_cache($@) { my $self = shift; $self->fail("Invalid method 'get_cache' in state $self->{_STATE}") unless $self->{_STATE} eq 'SELECTED'; my $mailbox = $self->{_SELECTED} // $self->panic(); $self->panic("Pending VANISHED responses!") if @{$self->{_VANISHED}}; $self->panic("Pending FLAG updates!") if %{$self->{_MODIFIED}}; my $cache = $self->{_PCACHE}->{$mailbox}; return @_ ? @$cache{@_} : %$cache; } # $self->is_dirty($mailbox) # Return true if there are pending updates for $mailbox, i.e., if its # internal cache's HIGHESTMODSEQ or UIDNEXT values differ from its # persistent cache's values. sub is_dirty($$) { my ($self, $mailbox) = @_; return 1 if $self->{_NEW}; $self->_updated_cache($mailbox, qw/HIGHESTMODSEQ UIDNEXT/); } # $self->has_new_mails($mailbox) # Return true if there are new messages in $mailbox, i.e., if its # internal cache's UIDNEXT value differs from its persistent cache's. sub has_new_mails($$) { my ($self, $mailbox) = @_; return 1 if $self->{_NEW}; $self->_updated_cache($mailbox, 'UIDNEXT'); } # $self->next_dirty_mailbox(@mailboxes) # Return the name of a dirty mailbox, or undef if all mailboxes are # clean. If @mailbox is non-empty, only consider mailboxes in that # list. sub next_dirty_mailbox($@) { my $self = shift; my %mailboxes = map {$_ => 1} @_; my @dirty = grep { (!%mailboxes or $mailboxes{$_}) and $self->is_dirty($_) } keys %{$self->{_CACHE}}; if ($self->{debug}) { @dirty ? $self->logger("Dirty mailboxes: ".join(', ', @dirty)) : $self->logger("Clean state!"); } return $dirty[0]; } # $self->pull_updates([$full]) # If $full is set, FETCH FLAGS and MODSEQ for each UID up to # UIDNEXT-1. # Get pending updates (unprocessed VANISHED responses and FLAG # updates), and empty these lists from the cache. # Finally, update the HIGHESTMODSEQ from the persistent cache to the # value found in the internal cache. sub pull_updates($;$) { my $self = shift; my $full = shift // 0; my $mailbox = $self->{_SELECTED} // $self->panic(); my $pcache = $self->{_PCACHE}->{$mailbox}; my %modified; $self->_send("UID FETCH 1:".($pcache->{UIDNEXT}-1)." (MODSEQ FLAGS)") if $full and ($pcache->{UIDNEXT} // 1) > 1; my @missing; while (%{$self->{_MODIFIED}}) { while (my ($uid,$v) = each %{$self->{_MODIFIED}}) { # don't filter on the fly (during FETCH responses) because # FLAG updates can arrive while processing pull_new_messages # for instance if (defined $v->[1] and $v->[0] > 0) { # setting the MODSEQ to 0 forces a FETCH next unless $uid < ($pcache->{UIDNEXT} // 1) # out of bounds and ($full or $v->[0] > ($pcache->{HIGHESTMODSEQ} // 0)); # already seen $modified{$uid} = $full ? $v : $v->[1]; } else { push @missing, $uid; } } $self->{_MODIFIED} = {}; $self->_send("UID FETCH ".compact_set(@missing)." (MODSEQ FLAGS)") if @missing; @missing = (); } # do that afterwards since the UID FETCH command above can produce VANISHED responses my %vanished = map {$_ => 1} grep { $_ < ($pcache->{UIDNEXT} // 1) } @{$self->{_VANISHED}}; my @vanished = keys %vanished; $self->{_VANISHED} = []; # ignore FLAG updates on VANISHED messages delete @modified{@vanished}; # update the persistent cache for HIGHESTMODSEQ (not for UIDNEXT # since there might be new messages) $self->set_cache($mailbox, %{$self->{_CACHE}->{$mailbox}}{HIGHESTMODSEQ}); return (\@vanished, \%modified); } # $self->pull_new_messages($attrs, $callback, @ignore) # 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, 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 # found in the internal cache. # /!\ Use pull_updates afterwards to udpate the HIGHESTMODSEQ! sub pull_new_messages($$&@) { my $self = shift; my $attrs = shift; my $callback = shift; my @ignore = sort { $a <=> $b } @_; my $mailbox = $self->{_SELECTED} // $self->panic(); my $cache = $self->{_CACHE}->{$mailbox}; my $UIDNEXT; do { my $range = ''; my $first; my $since = $self->{_PCACHE}->{$mailbox}->{UIDNEXT} || 1; foreach my $uid (@ignore) { if ($since < $uid) { $first //= $since; $range .= ',' if $range ne ''; $range .= $since; $range .= ':'.($uid-1) if $since < $uid-1; $since = $uid+1; } elsif ($since == $uid) { $since++; } } $first //= $since; $range .= ',' if $range ne ''; # 2^32-1: don't use '*' since the highest UID can be known already $range .= "$since:4294967295"; $UIDNEXT = $cache->{UIDNEXT} // $self->panic(); # sanity check $self->_send("UID FETCH $range ($attrs)", sub($) { my $mail = shift; $UIDNEXT = $mail->{UID} + 1 if $UIDNEXT <= $mail->{UID}; $callback->($mail) if defined $callback; }) if $first < $UIDNEXT or $self->{_NEW}; # update the persistent cache for UIDNEXT (not for HIGHESTMODSEQ # since there might be pending updates) $self->set_cache($mailbox, UIDNEXT => $UIDNEXT); $self->{_NEW} = 0; } # loop if new messages were received in the meantime while ($self->{_NEW} or $UIDNEXT < $cache->{UIDNEXT}); } # $self->push_flag_updates($flags, @set) # Change the flags to each UID in @set to $flags. # A flag update fails for mails being updated after the HIGHESTMODSEQ # found in the persistent cache; push such messages to the MODIFIED # list. sub push_flag_updates($$@) { my $self = shift; my $flags = shift; my @set = @_; my $mailbox = $self->{_SELECTED} // $self->panic(); my $modseq = $self->{_PCACHE}->{$mailbox}->{HIGHESTMODSEQ} // $self->panic(); my $command = "UID STORE ".compact_set(@set)." FLAGS.SILENT ($flags) (UNCHANGEDSINCE $modseq)"; my %listed; $self->_send($command, sub($){ $listed{shift->{UID}}++; }); my %failed; if ($IMAP_text =~ /\A\Q$IMAP_cond\E \[MODIFIED ([0-9,:]+)\] $RE_TEXT_CHAR+\z/) { foreach (split /,/, $1) { if (/\A([0-9]+)\z/) { $failed{$1} = 1; } elsif (/\A([0-9]+):([0-9]+)\z/) { my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); $failed{$_} = 1 foreach ($min .. $max); } else { $self->panic($_); } } } my @ok; foreach my $uid (@set) { if ($failed{$uid}) { # $uid was listed in the MODIFIED response code $self->{_MODIFIED}->{$uid} //= [ 0, undef ]; # will be downloaded again in pull_updates delete $self->{_MODIFIED}->{$uid} if # got a FLAG update for $uid; ignore it if it's $flags defined $self->{_MODIFIED}->{$uid}->[1] and $self->{_MODIFIED}->{$uid}->[1] eq $flags; } else { # $uid wasn't listed in the MODIFIED response code next unless defined $self->{_MODIFIED}->{$uid}; # already stored $self->panic() unless defined $listed{$uid} and $listed{$uid} > 0; # sanity check if ($listed{$uid} == 1) { # ignore succesful update delete $self->{_MODIFIED}->{$uid}; } elsif ($self->{_MODIFIED}->{$uid}->[1] and $self->{_MODIFIED}->{$uid}->[1] eq $flags) { # got multiple FETCH responses for $uid, the last one with $flags delete $self->{_MODIFIED}->{$uid}; } push @ok, $uid; } } unless ($self->{quiet}) { $self->log("Updated flags ($flags) for UID ".compact_set(@ok)) if @ok; $self->log("Couldn't update flags ($flags) for UID ".compact_set(keys %failed).', '. "trying again later") if %failed; } return keys %failed; } # $self->silent_store($set, $mod, @flags) # Set / Add / Remove the flags list on the UID $set, depending on the # value of $mod ('' / '+' / '-'). # /!\ There is no guaranty that message flags are successfully updated! sub silent_store($$$@) { my $self = shift; my $set = shift; my $mod = shift; $self->_send("UID STORE $set ${mod}FLAGS.SILENT (".join(' ', @_).")"); } # $self->expunge($set) # Exunge the given UID $set. # /!\ There is no guaranty that messages are successfully expunged! sub expunge($$) { my $self = shift; my $set = shift; $self->fail("Server did not advertise UIDPLUS (RFC 4315) capability.") unless $self->_capable('UIDPLUS'); $self->_send("UID EXPUNGE $set"); } ############################################################################# # Private methods # $self->_ssl_error($error, [...]) # Log an SSL $error and exit with return value 1. sub _ssl_error($$@) { my $self = shift; $self->fail(@_) unless defined $self->{_SSL}; $self->log('SSL ERROR: ', @_); if ($self->{debug}) { while (my $err = Net::SSLeay::ERR_get_error()) { $self->log(Net::SSLeay::ERR_error_string($err)); } } exit 1; } # RFC 3986 appendix A my $RE_IPv4 = do { my $dec = qr/[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5]/; qr/$dec(?:\.$dec){3}/o }; my $RE_IPv6 = do { my $h16 = qr/[0-9A-Fa-f]{1,4}/; my $ls32 = qr/$h16:$h16|$RE_IPv4/o; qr/ (?: $h16 : ){6} $ls32 | :: (?: $h16 : ){5} $ls32 | (?: $h16 )? :: (?: $h16 : ){4} $ls32 | (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32 | (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32 | (?: (?: $h16 : ){0,3} $h16 )? :: $h16 : $ls32 | (?: (?: $h16 : ){0,4} $h16 )? :: $ls32 | (?: (?: $h16 : ){0,5} $h16 )? :: $h16 | (?: (?: $h16 : ){0,6} $h16 )? :: /xo }; # Opens a TCP socket to the given $host and $port. sub _tcp_connect($$$) { my ($self, $host, $port) = @_; my %hints = (socktype => SOCK_STREAM, protocol => IPPROTO_TCP); if ($host =~ qr/\A$RE_IPv4\z/o) { $hints{family} = AF_INET; $hints{flags} |= AI_NUMERICHOST; } elsif ($host =~ qr/\A\[($RE_IPv6)\]\z/o) { $host = $1; $hints{family} = AF_INET6; $hints{flags} |= AI_NUMERICHOST; } my ($err, @res) = getaddrinfo($host, $port, \%hints); $self->fail("Can't getaddrinfo: $err") if $err ne ''; SOCKETS: foreach my $ai (@res) { socket (my $s, $ai->{family}, $ai->{socktype}|SOCK_CLOEXEC, $ai->{protocol}) or $self->panic("socket: $!"); # timeout connect/read/write/... after 30s # XXX we need to pack the struct timeval manually: not portable! # https://stackoverflow.com/questions/8284243/how-do-i-set-so-rcvtimeo-on-a-socket-in-perl my $timeout = pack('l!l!', 30, 0); setsockopt($s, Socket::SOL_SOCKET, Socket::SO_RCVTIMEO, $timeout) or $self->fail("Can't setsockopt SO_RCVTIMEO: $!"); setsockopt($s, Socket::SOL_SOCKET, Socket::SO_SNDTIMEO, $timeout) or $self->fail("Can't setsockopt SO_RCVTIMEO: $!"); until (connect($s, $ai->{addr})) { next if $! == EINTR; # try again if connect(2) was interrupted by a signal next SOCKETS; } return $s; } $self->fail("Can't connect to $host:$port"); } sub _xwrite($$$) { my $self = shift; my ($offset, $length) = (0, length $_[1]); while ($length > 0) { my $n = syswrite($_[0], $_[1], $length, $offset); $self->fail("Can't write: $!") unless defined $n and $n > 0; $offset += $n; $length -= $n; } } sub _xread($$$) { my ($self, $fh, $length) = @_; my $offset = 0; my $buf; while ($length > 0) { my $n = sysread($fh, $buf, $length, $offset) // $self->fail("Can't read: $!"); $self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF $offset += $n; $length -= $n; } return $buf; } # $self->_proxify($proxy, $host, $port) # Initiate the given $proxy to proxy TCP connections to $host:$port. sub _proxify($$$$) { my ($self, $proxy, $host, $port) = @_; $port = getservbyname($port, 'tcp') // $self->fail("Can't getservbyname $port") unless $port =~ /\A[0-9]+\z/; $proxy =~ /\A([A-Za-z0-9]+):\/\/(\P{Control}*\@)?($RE_IPv4|\[$RE_IPv6\]|[^:]+)(:[A-Za-z0-9]+)?\z/ or $self->fail("Invalid proxy URI $proxy"); my ($proto, $userpass, $proxyhost, $proxyport) = ($1, $2, $3, $4); $userpass =~ s/\@\z// if defined $userpass; $proxyport = defined $proxyport ? $proxyport =~ s/\A://r : 1080; my $socket = $self->_tcp_connect($proxyhost, $proxyport); if ($proto eq 'socks5' or $proto eq 'socks5h') { my $resolv = $proto eq 'socks5h' ? 1 : 0; my $v = 0x05; # RFC 1928 VER protocol version my %mech = ( ANON => 0x00 ); $mech{USERPASS} = 0x02 if defined $userpass; $self->_xwrite($socket, pack('CCC*', 0x05, scalar (keys %mech), values %mech)); my ($v2, $m) = unpack('CC', $self->_xread($socket, 2)); $self->fail('SOCKSv5', 'Invalid protocol') unless $v == $v2; %mech = reverse %mech; my $mech = $mech{$m} // ''; if ($mech eq 'USERPASS') { # RFC 1929 Username/Password Authentication for SOCKS V5 my $v = 0x01; # current version of the subnegotiation my ($u, $pw) = split /:/, $userpass, 2; $self->_xwrite($socket, pack('C2', $v,length($u)).$u.pack('C',length($pw)).$pw); my ($v2, $r) = unpack('C2', $self->_xread($socket, 2)); $self->fail('SOCKSv5', 'Invalid protocol') unless $v == $v2; $self->fail('SOCKSv5', 'Authentication failed') unless $r == 0x00; } elsif ($mech ne 'ANON') { # $m == 0xFF $self->fail('SOCKSv5', 'No acceptable authentication methods'); } if ($host !~ /\A(?:$RE_IPv4|\[$RE_IPv6\])\z/ and !$resolv) { # resove the hostname $host locally my ($err, @res) = getaddrinfo($host, undef, {socktype => SOCK_RAW}); $self->fail("Can't getaddrinfo: $err") if $err ne ''; ($host) = first { defined $_ } map { my ($err, $ipaddr) = getnameinfo($_->{addr}, NI_NUMERICHOST, NIx_NOSERV); $err eq '' ? $ipaddr : undef } @res; $self->fail("Can't getnameinfo") unless defined $host; } # send a CONNECT command (CMD 0x01) my ($typ, $addr) = $host =~ /\A$RE_IPv4\z/ ? (0x01, Socket::inet_pton(AF_INET, $host)) : ($host =~ /\A\[($RE_IPv6)\]\z/ or $host =~ /\A($RE_IPv6)\z/) ? (0x04, Socket::inet_pton(AF_INET6, $1)) : (0x03, pack('C',length($host)).$host); $self->_xwrite($socket, pack('C4', $v, 0x01, 0x00, $typ).$addr.pack('n', $port)); ($v2, my $r, my $rsv, $typ) = unpack('C4', $self->_xread($socket, 4)); $self->fail('SOCKSv5', 'Invalid protocol') unless $v == $v2 and $rsv == 0x00; my $err = $r == 0x00 ? undef : $r == 0x01 ? 'general SOCKS server failure' : $r == 0x02 ? 'connection not allowed by ruleset' : $r == 0x03 ? 'network unreachable' : $r == 0x04 ? 'host unreachable' : $r == 0x05 ? 'connection refused' : $r == 0x06 ? 'TTL expired' : $r == 0x07 ? 'command not supported' : $r == 0x08 ? 'address type not supported' : $self->panic(); $self->fail('SOCKSv5', $err) if defined $err; my $len = $typ == 0x01 ? 4 : $typ == 0x03 ? unpack('C', $self->_xread($socket, 1)) : $typ == 0x04 ? 16 : $self->panic(); $self->_xread($socket, $len + 2); # consume (and ignore) the rest of the response return $socket; } else { $self->error("Unsupported proxy protocol $proto"); } } # $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'"); my $pkey = Net::SSLeay::X509_get_X509_PUBKEY($cert); unless (defined $pkey and Net::SSLeay::EVP_Digest($pkey, $type) eq $digest) { $self->warn("Fingerprint doesn't match! MiTM in action?"); $ok = 0; } } $self->{_SSL_PEER_VERIFIED} = $ok; } return $ok; # 1=accept cert, 0=reject } my %SSL_proto; BEGIN { sub _append_ssl_proto($$) { my ($k, $v) = @_; $SSL_proto{$k} = $v if defined $v; } _append_ssl_proto( "SSLv2", eval { Net::SSLeay::OP_NO_SSLv2() } ); _append_ssl_proto( "SSLv3", eval { Net::SSLeay::OP_NO_SSLv3() } ); _append_ssl_proto( "TLSv1", eval { Net::SSLeay::OP_NO_TLSv1() } ); _append_ssl_proto( "TLSv1.1", eval { Net::SSLeay::OP_NO_TLSv1_1() } ); _append_ssl_proto( "TLSv1.2", eval { Net::SSLeay::OP_NO_TLSv1_2() } ); _append_ssl_proto( "TLSv1.3", eval { Net::SSLeay::OP_NO_TLSv1_3() } ); } # $self->_start_ssl($socket) # Upgrade the $socket to SSL/TLS. sub _start_ssl($$) { my ($self, $socket) = @_; my $ctx = Net::SSLeay::CTX_new() or $self->panic("Failed to create SSL_CTX $!"); my $ssl_options = Net::SSLeay::OP_SINGLE_DH_USE() | Net::SSLeay::OP_SINGLE_ECDH_USE(); $self->{SSL_protocols} //= q{!SSLv2 !SSLv3 !TLSv1 !TLSv1.1}; my ($proto_include, $proto_exclude) = (0, 0); foreach (split /\s+/, $self->{SSL_protocols}) { my $neg = s/^!// ? 1 : 0; s/\.0$//; ($neg ? $proto_exclude : $proto_include) |= $SSL_proto{$_} // $self->panic("Unknown SSL protocol: $_"); } if ($proto_include != 0) { # exclude all protocols except those explictly included my $x = 0; $x |= $_ foreach values %SSL_proto; $x &= ~ $proto_include; $proto_exclude |= $x; } my @proto_exclude = grep { ($proto_exclude & $SSL_proto{$_}) != 0 } keys %SSL_proto; $self->log("Disabling SSL protocols: ".join(', ', sort @proto_exclude)) if $self->{debug}; $ssl_options |= $SSL_proto{$_} foreach @proto_exclude; $ssl_options |= Net::SSLeay::OP_NO_COMPRESSION(); # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_options.html Net::SSLeay::CTX_set_options($ctx, $ssl_options); # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_mode.html Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE() | Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER() | Net::SSLeay::MODE_AUTO_RETRY() | # don't fail SSL_read on renegociation Net::SSLeay::MODE_RELEASE_BUFFERS() ); if (defined (my $ciphers = $self->{SSL_cipherlist})) { Net::SSLeay::CTX_set_cipher_list($ctx, $ciphers) or $self->_ssl_error("Can't set cipher list"); } if ($self->{SSL_verify} // 1) { # verify the certificate chain my ($file, $path) = ($self->{SSL_CAfile} // '', $self->{SSL_CApath} // ''); if ($file ne '' or $path ne '') { Net::SSLeay::CTX_load_verify_locations($ctx, $file, $path) or $self->_ssl_error("Can't load verify locations"); } } else { 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); $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 == 0x0304 ? 'TLSv1.3' : '??'), $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); } # $self->_getline([$length]) # Read a line from the handle and strip the trailing CRLF, optionally # after reading a literal of the given $length (default: 0). # In list context, return a pair ($literal, $line); otherwise only # return the $line. # /!\ Don't use this method with non-blocking IO! sub _getline($;$) { my $self = shift; my $len = shift // 0; my ($stdout, $ssl) = @$self{qw/S _SSL/}; $self->fail("Lost connection") unless $stdout->opened(); my (@lit, @line); while(1) { unless (defined $self->{_OUTBUF}) { my ($buf, $n); # nothing cached: read some more if (defined $ssl) { ($buf, $n) = Net::SSLeay::read($ssl, $BUFSIZE); } else { $n = sysread($stdout, $buf, $BUFSIZE, 0); } $self->_ssl_error("Can't read: $!") unless defined $n; $self->_ssl_error("0 bytes read (got EOF)") unless $n > 0; # EOF $self->{_OUTRAWCOUNT} += $n; if (defined (my $i = $self->{_Z_INFLATE})) { $i->inflate($buf, $self->{_OUTBUF}) == Z_OK or $self->panic("Inflation failed: ", $i->msg()); } else { $self->{_OUTBUF} = $buf; } } if ($len == 0) { # read a regular line: stop after the first \r\n if ((my $idx = 1 + index($self->{_OUTBUF}, "\n")) > 0) { # found the EOL, we're done my $lit = join '', @lit; my $line = join '', @line, substr($self->{_OUTBUF}, 0, $idx); $self->{_OUTBUF} = substr($self->{_OUTBUF}, $idx); $self->{_OUTCOUNT} += length($lit) + length($line); $line =~ s/$CRLF\z// or $self->panic($line); $self->logger('S: '.(@lit ? '[...]' : ''), $line) if $self->{debug}; return (wantarray ? (\$lit, $line) : $line); } else { push @line, $self->{_OUTBUF}; undef $self->{_OUTBUF}; } } elsif ($len > 0) { # $len bytes of literal bytes to read if ($len < length($self->{_OUTBUF})) { push @lit, substr($self->{_OUTBUF}, 0, $len, ''); $len = 0; } else { push @lit, $self->{_OUTBUF}; $len -= length($self->{_OUTBUF}); undef $self->{_OUTBUF}; } } } } # $self->_update_cache( ATTRIBUTE => VALUE, [...] ) # Update the internal cache for the currently selected mailbox with # the given attributes and values. sub _update_cache($%) { my $self = shift; $self->_update_cache_for($self->{_SELECTED}, @_); } # $self->_update_cache_for( $mailbox, ATTRIBUTE => VALUE, [...] ) # Update the internal cache for $mailbox with the given attributes and # values. sub _update_cache_for($$%) { my $self = shift; my $mailbox = shift // $self->panic(); my $cache = $self->{_CACHE}->{$mailbox} //= {}; my %status = @_; while (my ($k, $v) = each %status) { if ($k eq 'UIDVALIDITY') { # try to detect UIDVALIDITY changes early (before starting the sync) $self->fail("UIDVALIDITY changed! ($cache->{UIDVALIDITY} != $v) ". "Need to invalidate the UID cache.") if defined $cache->{UIDVALIDITY} and $cache->{UIDVALIDITY} != $v; $self->{_PCACHE}->{$mailbox}->{UIDVALIDITY} //= $v; } $cache->{$k} = $v; } } # $self->_updated_cache($mailbox) # Return true if there are pending updates for $mailbox, i.e., if one # of its internal cache's @attrs value differs from the persistent # cache's value. sub _updated_cache($$@) { my ($self, $mailbox, @attrs) = @_; $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive my $cache = $self->{_CACHE}->{$mailbox} // return 1; my $pcache = $self->{_PCACHE}->{$mailbox} // return 1; foreach (@attrs) { return 1 unless $pcache->{$_} and defined $cache->{$_} and $pcache->{$_} == $cache->{$_}; } return 0; } # $self->_cmd_init($command) # Generate a new tag for the given $command, push both the # concatenation to the command buffer. $command can be a scalar or a # scalar reference. # Use the _cmd_extend and/or _cmd_extend_lit methods to extend the # command, and _cmd_flush to send it to the server. sub _cmd_init($$) { my $self = shift; my $tag = sprintf '%06d', $self->{_TAG}++; my $command = (defined $self->{_INBUF} ? $CRLF : '').$tag.' '.(ref $_[0] ? ${$_[0]} : $_[0]); $self->_cmd_extend(\$command); return $tag; } # $self->_cmd_extend($args) # Append $args to the command buffer. $args can be a scalar or a # scalar reference. If $args contains some literal(s) and the server # doesn't support LITERAL+, flush the command and wait for an answer # before each literal sub _cmd_extend($$) { my $self = shift; my $args = ref $_[0] ? $_[0] : \$_[0]; if ($self->{_LITPLUS} ne '') { # server supports LITERAL+: use $args as is $self->_cmd_extend_($args); } else { # server 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); $line =~ s/\{([0-9]+)\+\}$CRLF\z/{$1}$CRLF/ or $self->panic(); $litlen = $1; $self->_cmd_flush(\$line); my $x = $self->_getline(); $x =~ /\A\+ / or $self->panic($x); $offset = $idx+1; } my $line = substr($$args, $offset); $self->_cmd_extend_(\$line); } } # $self->_cmd_extend_lit($lit) # Append the literal $lit to the command buffer. $lit must be a # 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 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); if ($z_flush and defined $d) { $d->flush(\$self->{_INBUF}, Z_FULL_FLUSH) == Z_OK or $self->panic("Can't flush deflation stream: ", $d->msg()); } } else { # server doesn't supports LITERAL+ $self->_cmd_flush(\$strlen, ($z_flush ? Z_FULL_FLUSH : ())); my $x = $self->_getline(); $x =~ /\A\+ / or $self->panic($x); } $self->_cmd_extend_($lit); if ($z_flush and defined $d) { $d->flush(\$self->{_INBUF}, Z_FULL_FLUSH) == Z_OK or $self->panic("Can't flush deflation stream: ", $d->msg()); } } # $self->_cmd_flush([$crlf], [$z_flush]) # Append $crlf (default: $CRLF) to the command buffer, flush the # deflation stream by creating a flush point of type $z_flush # (default: Z_SYNC_FLUSH) if there is a compression layer, and finally # send the command to the server. sub _cmd_flush($;$$) { my $self = shift; $self->_cmd_extend_( $_[0] // \$CRLF ); my $z_flush = $_[1] // Z_SYNC_FLUSH; # the flush point type to use my ($stdin, $ssl) = @$self{qw/S _SSL/}; if ($self->{debug}) { # remove $CRLF and literals my ($offset, $litlen) = (0, $self->{_INBUFDBGLEN} // 0); while ( (my $idx = index($self->{_INBUFDBG}, "\n", $offset+$litlen)) >= 0) { my $line = substr($self->{_INBUFDBG}, $offset+$litlen, $idx+1-$offset-$litlen); $line =~ s/$CRLF\z// or $self->panic(); $self->logger('C: ', ($litlen > 0) ? '[...]' : '', $line); $litlen = $line =~ /\{([0-9]+)(\+)?\}\z/ ? $1 : 0; $offset = $idx+1; } $self->panic() if $offset+$litlen < length($self->{_INBUFDBG}); undef $self->{_INBUFDBG}; $self->{_INBUFDBGLEN} = $litlen; } if (defined (my $d = $self->{_Z_DEFLATE})) { $d->flush(\$self->{_INBUF}, $z_flush) == Z_OK or $self->panic("Can't flush deflation stream: ", $d->msg()); } my ($offset, $length) = (0, length($self->{_INBUF})); while ($length > 0) { my $written = defined $ssl ? Net::SSLeay::write_partial($ssl, $offset, $length, $self->{_INBUF}) : syswrite($stdin, $self->{_INBUF}, $length, $offset); $self->_ssl_error("Can't write: $!") unless defined $written and $written > 0; $offset += $written; $length -= $written; $self->{_INRAWCOUNT} += $written; } undef $self->{_INBUF}; } # $self->_cmd_extend_($args) # Append the scalar reference $args to the command buffer. Usually # one should use the higher-level method _cmd_extend as it takes care # of literals if the server doesn't support LITERAL+. sub _cmd_extend_($$) { my ($self, $args) = @_; $self->{_INCOUNT} += length($$args); # count IMAP traffic $self->{_INBUFDBG} .= $$args if $self->{debug}; if (defined (my $d = $self->{_Z_DEFLATE})) { $d->deflate($args, \$self->{_INBUF}) == Z_OK or $self->panic("Deflation failed: ", $d->msg()); } else { $self->{_INBUF} .= $$args; } } # $self->_send($command, [$callback]) # Send the given $command to the server, then wait for the response. # (The status condition and response text are respectively placed in # $IMAP_cond and $IMAP_text.) Each untagged response received in the # meantime is read, parsed and processed. The optional $callback, if # given, is executed with all untagged responses associated with the # command. # In void context, croak unless the server answers with a tagged 'OK' # response. Otherwise, return the condition status ('OK'/'NO'/'BAD'). sub _send($$;&) { my $self = shift; my $command = \$_[0]; my $callback = $_[1]; my $tag = $self->_cmd_init($command); $self->_cmd_flush(); my $cmd = $$command =~ /\AUID ($RE_ATOM_CHAR+) / ? $1 : $$command =~ /\A($RE_ATOM_CHAR+) / ? $1 : $$command; if (!defined $callback) { $self->_recv($tag, undef, $cmd); } else { my $set = $$command =~ /\AUID (?:FETCH|STORE) ([0-9:,*]+)/ ? $1 : $$command =~ /\AUID SEARCH / ? $tag # for RFC 4466's tag-string : undef; $self->_recv($tag, $callback, $cmd, $set); } } # $self->_recv($tag, [$callback, $command, $set]) # Wait for a tagged response with the given $tag. The $callback, if # provided, is used to process each untagged response. $command and # $set can further limit the set of responses to apply the callback # to. sub _recv($$;&$$) { my ($self, $tag, $callback, $cmd, $set) = @_; my $r; # wait for the answer while (1) { my $x = $self->_getline(); if ($x =~ s/\A\Q$tag\E (OK|NO|BAD) //) { $IMAP_cond = $1; $IMAP_text = $1.' '.$x; $self->_resp_text($x); $self->fail($IMAP_text) unless defined wantarray or $IMAP_cond eq 'OK'; $r = $1; last; } else { $self->_resp($x, $callback, $cmd, $set); } } if (defined $self->{_SELECTED}) { my $mailbox = $self->{_SELECTED}; my $cache = $self->{_CACHE}->{$mailbox}; # can't keep track of the modification sequences $self->fail("Mailbox $mailbox doesn't support MODSEQ.") if $cache->{NOMODSEQ} and $self->_enabled('QRESYNC'); $self->fail("Mailbox $mailbox does not support persistent UIDs.") if defined $cache->{UIDNOTSTICKY}; } return $r; } # $self->_capable($capability, [...]) # Return true if each $capability is listed in the server's CAPABILITY # list. sub _capable($@) { my $self = shift; return 0 unless defined $self->{_CAPABILITIES}; foreach my $cap (@_) { return 0 unless grep {uc $cap eq uc $_} @{$self->{_CAPABILITIES}}; } return 1; } # $self->_capable($extension) # Return true if $extension has been enabled by the server, i.e., the # server sent an untagged ENABLED response including it. sub _enabled($$) { my $self = shift; my $ext = uc shift; grep {$ext eq uc $_} @{$self->{_ENABLED} // []}; } # $self->_open_mailbox($mailbox) # Initialize the internal and persistent caches for $mailbox, and mark # it as selected. sub _open_mailbox($$) { my $self = shift; my $mailbox = shift; # it is safe to wipe cached VANISHED responses or FLAG updates, # because interesting stuff must have made the mailbox dirty so # we'll get back to it $self->{_VANISHED} = []; $self->{_MODIFIED} = {}; $self->{_NEW} = 0; $self->{_SELECTED} = $mailbox; $self->{_CACHE}->{$mailbox} //= {}; # always reset EXISTS to keep track of new mails delete $self->{_CACHE}->{$mailbox}->{EXISTS}; } # $self->_select_or_examine($command, $mailbox, [$seqs, $UIDs]) # Issue a SELECT or EXAMINE command for the $mailbox. Upon success, # change the state to SELECTED, otherwise go back to AUTH. # The optional $seqs and $UIDs are used as Message Sequence Match # Data for the QRESYNC parameter to the $command. sub _select_or_examine($$$;$$) { my $self = shift; my $command = shift; my $mailbox = shift; my ($seqs, $uids) = @_; $mailbox = uc $mailbox eq 'INBOX' ? 'INBOX' : $mailbox; # INBOX is case-insensitive my $pcache = $self->{_PCACHE}->{$mailbox} //= {}; my $cache = $self->{_CACHE}->{$mailbox} //= {}; $cache->{UIDVALIDITY} = $pcache->{UIDVALIDITY} if defined $pcache->{UIDVALIDITY}; $command .= ' '.quote($mailbox); if ($self->_enabled('QRESYNC') and ($pcache->{HIGHESTMODSEQ} // 0) > 0 and ($pcache->{UIDNEXT} // 1) > 1) { $command .= " (QRESYNC ($pcache->{UIDVALIDITY} $pcache->{HIGHESTMODSEQ} " ."1:".($pcache->{UIDNEXT}-1); $command .= " ($seqs $uids)" if defined $seqs and defined $uids; $command .= "))"; } if ($self->{_STATE} eq 'SELECTED' and ($self->_capable('CONDSTORE') or $self->_capable('QRESYNC'))) { # A mailbox is currently selected and the server advertises # 'CONDSTORE' or 'QRESYNC' (RFC 7162). Delay the mailbox # selection until the [CLOSED] response code has been received: # all responses before the [CLOSED] response code refer to the # previous mailbox ($self->{_SELECTED}), while all subsequent # responses refer to the new mailbox $self->{_SELECTED_DELAYED}. $self->{_SELECTED_DELAYED} = $mailbox; } else { $self->_open_mailbox($mailbox); } $self->{_STATE} = 'AUTH'; $self->_send($command); $self->{_STATE} = 'SELECTED'; } sub _kibi($) { my $n = shift; if ($n < 1024) { $n; } elsif ($n < 1048576) { sprintf '%.2fK', $n / 1024.; } elsif ($n < 1073741824) { sprintf '%.2fM', $n / 1048576.; } else { sprintf '%.2fG', $n / 1073741824.; } } ############################################################################# # Parsing methods # # Parse an RFC 3501 (+extensions) resp-text, and update the cache when needed. sub _resp_text($$) { my $self = shift; local $_ = shift; if (/\A\[ALERT\] $RE_TEXT_CHAR+\z/) { $self->log($_); } elsif (/\A\[BADCHARSET .*\] $RE_TEXT_CHAR+\z/) { $self->fail($_); } elsif (/\A\[CAPABILITY((?: $RE_ATOM_CHAR+)+)\] $RE_TEXT_CHAR+\z/) { $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ]; $self->{_LITPLUS} = (grep { uc $_ eq 'LITERAL+' } @{$self->{_CAPABILITIES}}) ? '+' : ''; } elsif (/\A\[PERMANENTFLAGS \(((?:(?:\\?$RE_ATOM_CHAR+|\\\*)(?: (?:\\?$RE_ATOM_CHAR+|\\\*))*))\)\] $RE_TEXT_CHAR+\z/) { $self->_update_cache( PERMANENTFLAGS => [ split / /, $1 ] ); } elsif (/\A\[(READ-ONLY|READ-WRITE)\] $RE_TEXT_CHAR+\z/) { $self->_update_cache($1 => 1); } elsif (/\A\[(UIDNEXT|UIDVALIDITY|UNSEEN) ([0-9]+)\] $RE_TEXT_CHAR+\z/) { $self->_update_cache($1 => $2); } elsif (/\A\[HIGHESTMODSEQ ([0-9]+)\] $RE_TEXT_CHAR+\z/) { # RFC 4551/7162 CONDSTORE/QRESYNC $self->_update_cache(HIGHESTMODSEQ => $1); } elsif (/\A\[NOMODSEQ\] $RE_TEXT_CHAR+\z/) { # RFC 4551/7162 CONDSTORE/QRESYNC $self->_update_cache(NOMODSEQ => 1); } elsif (/\A\[CLOSED\] $RE_TEXT_CHAR+\z/) { # RFC 7162 CONDSTORE/QRESYNC # Update the selected mailbox: previous responses refer to the # previous mailbox ($self->{_SELECTED}), while all subsequent # responses refer to the new mailbox $self->{_SELECTED_DELAYED}. my $mailbox = delete $self->{_SELECTED_DELAYED} // $self->panic(); $self->_open_mailbox($mailbox); } elsif (/\A\[(?:NOTIFICATIONOVERFLOW|BADEVENT .*)\] $RE_TEXT_CHAR+\z/) { # RFC 5465 NOTIFY $self->fail($_); } elsif (/\A\[UIDNOTSTICKY\] $RE_TEXT_CHAR+\z/) { # RFC 4315 UIDPLUS $self->_update_cache(UIDNOTSTICKY => 1); } } # Parse and consume an RFC 3501 nstring (string / "NIL"). sub _nstring($$) { my ($self, $stream) = @_; return $$stream =~ s/\ANIL// ? undef : $self->_string($stream); } # Parse and consume an RFC 3501 astring (1*ASTRING-CHAR / string). sub _astring($$) { my ($self, $stream) = @_; return $$stream =~ s/\A$RE_ASTRING_CHAR+//p ? ${^MATCH} : $self->_string($stream); } # Parse and consume an RFC 3501 list-mailbox (1*list-char / string). sub _list_mailbox($$) { my ($self, $stream) = @_; return $$stream =~ s/\A$RE_LIST_CHAR+//p ? ${^MATCH} : $self->_string($stream); } # Parse and consume an RFC 3501 string (quoted / literal). sub _string($$) { my ($self, $stream) = @_; if ($$stream =~ s/\A"((?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])*)"//) { # quoted my $str = $1; $str =~ s/\\([\x22\x5C])/$1/g; return $str; } elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) { # literal (my $lit, $$stream) = $self->_getline($1); return $$lit; } else { $self->panic($$stream); } } # Parse and consume an RFC 3501 "(" 1*address ")" / "NIL". sub _addresses($$) { my ($self, $stream) = @_; return undef if $$stream =~ s/\ANIL//; my @addresses; $$stream =~ s/\A\(// or $self->panic($$stream); while ($$stream =~ s/\A ?\(//) { my @addr; push @addr, $self->_nstring($stream); # addr-name $$stream =~ s/\A // or $self->panic($$stream); push @addr, $self->_nstring($stream); # addr-adl $$stream =~ s/\A // or $self->panic($$stream); push @addr, $self->_nstring($stream); # addr-mailbox $$stream =~ s/\A // or $self->panic($$stream); push @addr, $self->_nstring($stream); # addr-host $$stream =~ s/\A\)// or $self->panic($$stream); push @addresses, \@addr; } $$stream =~ s/\A\)// or $self->panic($$stream); return \@addresses; } # Parse and consume an RFC 3501 envelope sub _envelope($$) { my ($self, $stream) = @_; $$stream =~ s/\A\(// or $self->panic($$stream); my @envelope; push @envelope, $self->_nstring($stream); # env-date $$stream =~ s/\A // or $self->panic($$stream); push @envelope, $self->_nstring($stream); # env-subject $$stream =~ s/\A // or $self->panic($$stream); push @envelope, $self->_addresses($stream); # env-from $$stream =~ s/\A // or $self->panic($$stream); push @envelope, $self->_addresses($stream); # env-sender $$stream =~ s/\A // or $self->panic($$stream); push @envelope, $self->_addresses($stream); # env-reply-to $$stream =~ s/\A // or $self->panic($$stream); push @envelope, $self->_addresses($stream); # env-to $$stream =~ s/\A // or $self->panic($$stream); push @envelope, $self->_addresses($stream); # env-cc $$stream =~ s/\A // or $self->panic($$stream); push @envelope, $self->_addresses($stream); # env-bcc $$stream =~ s/\A // or $self->panic($$stream); push @envelope, $self->_nstring($stream); # env-in-reply-to $$stream =~ s/\A // or $self->panic($$stream); push @envelope, $self->_nstring($stream); # env-message-id $$stream =~ s/\A\)// or $self->panic($$stream); return \@envelope; } # Parse and consume an RFC 4466 tagged-ext-comp plus a trailing parenthesis sub _tagged_ext_comp($$$) { my ($self, $stream, $ret) = @_; my $v = $$stream =~ s/\A\(// ? $self->_tagged_ext_comp(\$_, []) : $self->_astring(\$_); push @$ret, $v; if ($$stream =~ s/\A\)//) { return $ret; } elsif ($$stream =~ s/\A //) { $self->_tagged_ext_comp(\$_, $ret) } else { $self->panic($$stream); } } # $self->_resp($buf, [$callback, $cmd, $set] ) # Parse an untagged response line or a continuation request line. # (The trailing CRLF must be removed.) The internal cache is # automatically updated when needed. # If a command and callback are given, the callback is be executed # for each (parsed) responses associated with the command. sub _resp($$;&$$) { my $self = shift; local $_ = shift; my $callback = shift; my $cmd = shift; my $set = shift; my $cache = $self->{_CACHE}->{$self->{_SELECTED}} if defined $self->{_SELECTED}; if (s/\A\* //) { if (s/\ABYE //) { undef $self; } elsif (s/\A(?:OK|NO|BAD) //) { $self->_resp_text($_); $callback->($self->{_SELECTED}) if defined $self->{_SELECTED} and defined $callback and $cmd eq 'slurp'; } elsif (/\ACAPABILITY((?: $RE_ATOM_CHAR+)+)\z/) { $self->{_CAPABILITIES} = [ split / /, ($1 =~ s/^ //r) ]; } elsif (/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)\z/) { $cache->{FLAGS} = [ split / /, $1 ]; } elsif (/\A([0-9]+) RECENT\z/) { $cache->{RECENT} = $1; } elsif (/\A([0-9]+) EXISTS\z/) { # /!\ $cache->{EXISTS} MUST NOT be defined on SELECT if (defined $cache->{EXISTS}) { $self->panic("Unexpected EXISTS shrink $1 < $cache->{EXISTS}!") if $1 < $cache->{EXISTS}; $self->{_NEW} += $1 - $cache->{EXISTS} if $1 > $cache->{EXISTS}; # new mails } $cache->{EXISTS} = $1; $callback->($self->{_SELECTED} // $self->panic(), EXISTS => $1) if defined $callback and $cmd eq 'slurp'; } elsif (/\A([0-9]+) EXPUNGE\z/) { $self->panic() unless defined $cache->{EXISTS}; # sanity check # /!\ No bookkeeping since there is no internal cache mapping sequence numbers to UIDs if ($self->_enabled('QRESYNC')) { $self->panic("$1 <= $cache->{EXISTS}") if $1 <= $cache->{EXISTS}; # sanity check $self->fail("RFC 7162 violation! Got an EXPUNGE response with QRESYNC enabled."); } # the new message was expunged before it was synced $self->{_NEW} = 0 if $self->{_NEW} == 1 and $cache->{EXISTS} == $1; $cache->{EXISTS}--; # explicit EXISTS responses are optional } elsif (/\ASEARCH((?: [0-9]+)*)\z/) { $callback->(split(/ /, ($1 =~ s/^ //r))) if defined $callback and $cmd eq 'SEARCH'; } elsif (s/\AESEARCH( |\z)/$1/) { my $tag = $1 if s/\A \(TAG \"($RE_ASTRING_CHAR+)\"\)//; my $uid = s/\A UID// ? "UID" : undef; my @ret; while ($_ ne '') { # RFC 4466 "tagged-ext-label" is a valid RFC 3501 "atom" s/\A ($RE_ATOM_CHAR+) // or $self->panic(); my $label = uc($1); my $value; if (s/\A([0-9,:]+)//) { # RFC 4466 tagged-ext-simple $value = $1; } elsif (s/\A\(//) { # RFC 4466 "(" [tagged-ext-comp] ")" $value = s/\A\)// ? [] : $self->_tagged_ext_comp(\$_, []); } else { $self->panic(); } # don't use a hash since some extensions might give more # than one response for a same key push @ret, $label => $value; } $callback->($uid, @ret) if defined $callback and $cmd eq 'SEARCH' and defined $set and $set eq $tag; } elsif (s/\ALIST \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\) ("(?:\\[\x22\x5C]|[\x01-\x09\x0B\x0C\x0E-\x21\x23-\x5B\x5D-\x7F])"|NIL) //) { my ($delim, $attrs) = ($2, $1); my @attrs = defined $attrs ? split(/ /, $attrs) : (); my $mailbox = $self->_list_mailbox(\$_); $self->panic($_) unless $_ eq ''; $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive undef $delim if uc $delim eq 'NIL'; $self->panic($_) if defined $delim and $delim !~ s/\A"\\?(.)"\z/$1/; $self->_update_cache_for($mailbox, DELIMITER => $delim); $self->_update_cache_for($mailbox, LIST_ATTRIBUTES => \@attrs); $callback->($mailbox, $delim, @attrs) if defined $callback and $cmd eq 'LIST'; } elsif (s/\ASTATUS //) { my $mailbox = $self->_astring(\$_); /\A \((\\?$RE_ATOM_CHAR+ [0-9]+(?: \\?$RE_ATOM_CHAR+ [0-9]+)*)?\)\z/ or $self->panic($_); my %status = split / /, $1; $mailbox = 'INBOX' if uc $mailbox eq 'INBOX'; # INBOX is case-insensitive $self->panic("RFC 5465 violation! Missing HIGHESTMODSEQ data item in STATUS response") if $self->_enabled('QRESYNC') and !defined $status{HIGHESTMODSEQ} and defined $cmd and ($cmd eq 'NOTIFY' or $cmd eq 'slurp'); $self->_update_cache_for($mailbox, %status); if (defined $callback) { if ($cmd eq 'STATUS') { $callback->($mailbox, %status); } elsif ($cmd eq 'slurp') { $callback->($mailbox); } } } elsif (s/\A([0-9]+) FETCH \(//) { $cache->{EXISTS} = $1 if $1 > $cache->{EXISTS}; my ($seq, $first) = ($1, 1); my %mail; while ($_ ne ')') { unless (defined $first) { s/\A // or $self->panic($_); } if (s/\AUID ([0-9]+)//) { # always present, cf RFC 3501 section 6.4.8 $mail{UID} = $1; # the actual UIDNEXT is *at least* that $cache->{UIDNEXT} = $1+1 if !defined $cache->{UIDNEXT} or $cache->{UIDNEXT} <= $1; } if (s/\AMODSEQ \(([0-9]+)\)//) { # RFC 4551/7162 CONDSTORE/QRESYNC # always present in unsolicited FETCH responses if QRESYNC has been enabled $mail{MODSEQ} = $1; $cache->{HIGHESTMODSEQ} = $1 if !defined $cache->{HIGHESTMODSEQ} or $cache->{HIGHESTMODSEQ} < $1; } elsif (s/\AENVELOPE //) { $mail{ENVELOPE} = $self->_envelope(\$_); } elsif (s/\AINTERNALDATE "([^"]+)"//) { $mail{INTERNALDATE} = $1; } elsif (s/\A(?:RFC822|BODY\[\]) //) { $mail{RFC822} = \$self->_nstring(\$_); } elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) { $mail{FLAGS} = defined $1 ? [ split / /, $1 ] : []; } undef $first; } $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check my $uid = $mail{UID}; if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails defined $uid and # /!\ ignore unsolicited FETCH responses without UID, cf RFC 7162 section 3.2.4 (!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}; $self->{_MODIFIED}->{$uid} = [ $mail{MODSEQ}, $flags ]; } if (defined $callback) { if ($cmd eq 'FETCH' or $cmd eq 'STORE') { $callback->(\%mail) if defined $uid and in_set($uid, $set); } elsif ($cmd eq 'slurp') { $callback->($self->{_SELECTED} // $self->panic(), FETCH => $seq) } } } elsif (/\AENABLED((?: $RE_ATOM_CHAR+)+)\z/) { # RFC 5161 ENABLE $self->{_ENABLED} //= []; push @{$self->{_ENABLED}}, split(/ /, ($1 =~ s/^ //r)); } elsif (/\AVANISHED( \(EARLIER\))? ([0-9,:]+)\z/) { # RFC 7162 QRESYNC my $earlier = defined $1 ? 1 : 0; my $set = $2; my $mailbox = $self->{_SELECTED} // $self->panic(); my $pcache = $self->{_PCACHE}->{$mailbox}; foreach (split /,/, $set) { if (/\A([0-9]+)\z/) { $cache->{EXISTS}-- unless $earlier; # explicit EXISTS responses are optional $cache->{UIDNEXT} = $1+1 if $cache->{UIDNEXT} <= $1; # the actual UIDNEXT is *at least* that push @{$self->{_VANISHED}}, $1; } elsif (/\A([0-9]+):([0-9]+)\z/) { my ($min, $max) = $1 < $2 ? ($1,$2) : ($2,$1); $cache->{EXISTS} -= $max-$min+1 unless $earlier; # explicit EXISTS responses are optional $cache->{UIDNEXT} = $max+1 if $cache->{UIDNEXT} <= $max; # the actual UIDNEXT is *at least* that push @{$self->{_VANISHED}}, ($min .. $max); } } $callback->($self->{_SELECTED} // $self->panic()) if defined $callback and $cmd eq 'slurp'; } } elsif (s/\A\+// and ($_ eq '' or s/\A //)) { # Microsoft Exchange Server 2010 violates RFC 3501 by skipping the trailing ' ' for empty resp-text if (defined $callback and $cmd eq 'AUTHENTICATE') { my $x = $callback->($_); $self->_cmd_extend(\$x); $self->_cmd_flush(); } } else { $self->panic("Unexpected response: ", $_); } } ############################################################################# return 1;