aboutsummaryrefslogtreecommitdiffstats
path: root/pullimap
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem@fripost.org>2016-03-07 18:21:46 +0100
committerGuilhem Moulin <guilhem@fripost.org>2016-03-07 18:21:46 +0100
commit58d6bd5be5ce08c55448a82ea20039808c1e214e (patch)
tree3c45eaf0aafd07fcad082595a6296b477d8573e5 /pullimap
parent5f97601949f10e085a0df740c628cbfbfdf1d49f (diff)
parentfeb047ee7fcc1f93bc1e76626e16651761e0db55 (diff)
Merge branch 'master' into debian
Diffstat (limited to 'pullimap')
-rwxr-xr-xpullimap331
1 files changed, 331 insertions, 0 deletions
diff --git a/pullimap b/pullimap
new file mode 100755
index 0000000..27226d2
--- /dev/null
+++ b/pullimap
@@ -0,0 +1,331 @@
+#!/usr/bin/perl -T
+
+#----------------------------------------------------------------------
+# Pull mails from an IMAP mailbox and deliver them to a SMTP session
+# Copyright © 2016 Guilhem Moulin <guilhem@fripost.org>
+#
+# 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 <http://www.gnu.org/licenses/>.
+#----------------------------------------------------------------------
+
+use strict;
+use warnings;
+
+our $VERSION = '0.3';
+my $NAME = 'pullimap';
+
+use Errno 'EINTR';
+use Fcntl qw/O_CREAT O_RDWR O_DSYNC LOCK_EX SEEK_SET F_GETFL F_SETFL FD_CLOEXEC/;
+use Getopt::Long qw/:config posix_default no_ignore_case gnu_getopt auto_version/;
+use List::Util 'first';
+use Socket qw/PF_INET PF_INET6 SOCK_STREAM/;
+
+use lib 'lib';
+use Net::IMAP::InterIMAP qw/read_config compact_set/;
+
+my %CONFIG;
+sub usage(;$) {
+ my $rv = shift // 0;
+ if ($rv) {
+ print STDERR "Usage: $NAME [OPTIONS] SECTION\n"
+ ."Try '$NAME --help' or consult the manpage for more information.\n";
+ }
+ else {
+ print STDERR "Usage: $NAME [OPTIONS] SECTION\n"
+ ."Consult the manpage for more information.\n";
+ }
+ exit $rv;
+}
+
+usage(1) unless GetOptions(\%CONFIG, qw/config=s quiet|q debug help|h idle:i no-delivery/);
+usage(0) if $CONFIG{help};
+usage(1) unless $#ARGV == 0 and $ARGV[0] ne '_';
+
+
+#######################################################################
+# Read and validate configuration
+#
+my $CONF = read_config( delete $CONFIG{config} // $NAME,
+ , [$ARGV[0]]
+ , statefile => qr/\A(\P{Control}+)\z/
+ , mailbox => qr/\A([\x01-\x7F]+)\z/
+ , 'deliver-method' => qr/\A([ls]mtp:\[.*\]:\d+)\z/
+ , 'deliver-ehlo' => qr/\A(\P{Control}+)\z/
+ , 'deliver-rcpt' => qr/\A(\P{Control}+)\z/
+ , 'purge-after' => qr/\A(\d+)\z/
+ )->{$ARGV[0]};
+
+my ($MAILBOX, $STATE);
+do {
+ $MAILBOX = $CONF->{mailbox} // 'INBOX';
+
+ my $statefile = $CONF->{statefile} // $ARGV[0];
+ die "Missing option statefile" unless defined $statefile;
+ $statefile = $statefile =~ /\A(\p{Print}+)\z/ ? $1 : die "Insecure $statefile";
+
+ unless ($statefile =~ /\A\//) {
+ my $dir = ($ENV{XDG_DATA_HOME} // "$ENV{HOME}/.local/share") .'/'. $NAME;
+ $dir = $dir =~ /\A(\/\p{Print}+)\z/ ? $1 : die "Insecure $dir";
+ $statefile = $dir .'/'. $statefile;
+ unless (-d $dir) {
+ mkdir $dir, 0700 or die "Can't mkdir $dir: $!\n";
+ }
+ }
+
+ sysopen($STATE, $statefile, O_CREAT|O_RDWR|O_DSYNC, 0600) or die "Can't open $statefile: $!";
+ my $flags = fcntl($STATE, F_GETFL, 0) or die "fcntl F_GETFL: $!";
+ fcntl($STATE, F_SETFL, $flags | FD_CLOEXEC) or die "fcntl F_SETFL: $!";
+
+ flock($STATE, LOCK_EX) or die "Can't flock $statefile: $!";
+};
+
+
+#######################################################################
+
+# Read a UID (32-bits integer) from the statefile, or undef if we're at
+# the end of the statefile
+sub readUID() {
+ my $n = sysread($STATE, my $buf, 4) // die "Can't sysread: $!";
+ return if $n == 0; # EOF
+ # file length is a multiple of 4 bytes, and we always read 4 bytes at a time
+ die "Corrupted state file!" if $n != 4;
+ unpack('N', $buf);
+}
+
+# Write a UID (32-bits integer) to the statefile
+sub writeUID($) {
+ my $uid = pack('N', shift);
+ my $offset = 0;
+ for ( my $offset = 0
+ ; $offset < 4
+ ; $offset += syswrite($STATE, $uid, 4-$offset, $offset) // die "Can't syswrite: $!"
+ ) {}
+}
+
+
+#######################################################################
+# SMTP/LMTP part
+#
+my ($SMTP, $SMTP_PIPELINING);
+sub sendmail($$) {
+ my ($from, $rfc822) = @_;
+ unless (defined $SMTP) {
+ # TODO we need to be able to reconnect when the server closes
+ # the connection due to a timeout (RFC 5321 section 4.5.3.2)
+ my ($fam, $addr) = (PF_INET, $CONF->{'deliver-method'} // 'smtp:[127.0.0.1]:25');
+ $addr =~ s/^([ls]mtp):// or die;
+ my $ehlo = $1 eq 'lmtp' ? 'LHO' : $1 eq 'smtp' ? 'EHLO' : die;
+ $ehlo .= ' '. ($CONF->{'deliver-ehlo'} // 'localhost.localdomain');
+
+ my $port = $addr =~ s/:(\d+)$// ? $1 : die;
+ $addr =~ s/^\[(.*)\]$/$1/ or die;
+ $fam = PF_INET6 if $addr =~ /:/;
+ $addr = Socket::inet_pton($fam, $addr) // die "Invalid address $addr\n";
+ my $sockaddr = $fam == PF_INET ? Socket::pack_sockaddr_in($port, $addr)
+ : $fam == PF_INET6 ? Socket::pack_sockaddr_in6($port, $addr)
+ : die;
+
+ my $proto = getprotobyname("tcp") // die;
+ socket($SMTP, $fam, SOCK_STREAM, $proto) or die "socket: $!";
+ until (connect($SMTP, $sockaddr)) {
+ next if $! == EINTR; # try again if connect(2) was interrupted by a signal
+ die "connect: $!";
+ }
+
+ smtp_resp('220');
+ my @r = smtp_send($ehlo => '250');
+ $SMTP_PIPELINING = grep {$_ eq 'PIPELINING'} @r; # SMTP pipelining (RFC 2920)
+ }
+ my $rcpt = $CONF->{'deliver-rcpt'} // getpwuid($>) // die;
+
+ # return codes are from RFC 5321 section 4.3.2
+ smtp_send( "MAIL FROM:<$from>" => '250'
+ , "RCPT TO:<$rcpt>" => '250'
+ , "DATA" => '354'
+ );
+
+ print STDERR "C: [...]\n" if $CONFIG{debug};
+ if ($$rfc822 eq '') {
+ # RFC 5321 section 4.1.1.4: if there was no mail data, the first
+ # "\r\n" ends the DATA command itself
+ $SMTP->printflush("\r\n.\r\n");
+ } else {
+ my $offset = 0;
+ my $length = length($$rfc822);
+ while ((my $end = index($$rfc822, "\r\n", $offset) + 2) != 1) {
+ my $line = substr($$rfc822, $offset, $end-$offset);
+ # RFC 5321 section 4.5.2: the character sequence "\r\n.\r\n"
+ # ends the mail text and cannot be sent by the user
+ $SMTP->print($line eq ".\r\n" ? "..\r\n" : $line);
+ $offset = $end;
+ }
+ if ($offset < $length) {
+ # the last line did not end with "\r\n"; add it in order to
+ # have the receiving SMTP server recognize the "end of data"
+ # condition. See RFC 5321 section 4.1.1.4
+ my $line = substr($$rfc822, $offset);
+ $SMTP->print(($line eq "." ? ".." : $line), "\r\n");
+ }
+ $SMTP->printflush(".\r\n");
+ }
+ smtp_resp('250');
+}
+sub smtp_resp($) {
+ my $code = shift;
+ my @resp;
+ while(1) {
+ local $_ = $SMTP->getline() // die;
+ s/\r\n\z// or die "Invalid SMTP reply: $_";
+ print STDERR "S: $_\n" if $CONFIG{debug};
+ s/\A\Q$code\E([ -])// or die "SMTP error: Expected $code, got: $_\n";
+ push @resp, $_;
+ return @resp if $1 eq ' ';
+ }
+}
+sub smtp_send(@) {
+ my (@cmd, @code, @r);
+ while (@_) {
+ push @cmd, shift // die;
+ push @code, shift // die;
+ }
+ if ($SMTP_PIPELINING) { # SMTP pipelining (RFC 2920)
+ print STDERR join('', map {"C: $_\n"} @cmd) if $CONFIG{debug};
+ $SMTP->printflush(join('', map {"$_\r\n"} @cmd));
+ @r = smtp_resp($_) foreach @code;
+ }
+ else {
+ foreach (@cmd) {
+ print STDERR "C: $_\n" if $CONFIG{debug};
+ $SMTP->printflush("$_\r\n");
+ @r = smtp_resp(shift(@code));
+ }
+ }
+ return @r;
+}
+
+
+#######################################################################
+# Initialize the cache from the statefile, then pull new messages from
+# the remote mailbox
+#
+$CONF->{'logger-fd'} = \*STDERR if $CONFIG{debug};
+my $IMAP = Net::IMAP::InterIMAP::->new( %$CONF, %CONFIG{qw/quiet debug/} );
+
+# Remove messages with UID < UIDNEXT and INTERNALDATE at most
+# $CONF->{'purge-after'} days ago.
+my $LAST_PURGED;
+sub purge() {
+ my $days = $CONF->{'purge-after'} // return;
+ my ($uidnext) = $IMAP->get_cache('UIDNEXT');
+ return unless 1<$uidnext;
+ my $set = "1:".($uidnext-1);
+
+ my $now = time;
+ return if defined $LAST_PURGED and $now - $LAST_PURGED < 6*3600;
+ $LAST_PURGED = $now;
+
+ unless ($days == 0) {
+ my @now = gmtime($now - $days*86400);
+ my @m = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; # RFC 3501's date-month
+ my $date = sprintf("%02d-%s-%04d", $now[3], $m[$now[4]], $now[5]+1900);
+ my @uid = $IMAP->search("UID $set BEFORE $date");
+ return unless @uid;
+
+ $set = compact_set(@uid);
+ $IMAP->log("Removing ".($#uid+1)." UID(s) $set") unless $CONFIG{quiet};
+ }
+ $IMAP->silent_store($set, '+', '\Deleted');
+ $IMAP->expunge($set);
+}
+
+# Use BODY.PEEK[] so if something gets wrong, unpulled messages
+# won't be marked as \Seen in the mailbox
+my $ATTRS = "ENVELOPE INTERNALDATE BODY.PEEK[]";
+
+# Pull new messages from IMAP and deliver them to SMTP, then update the
+# statefile
+sub pull(;$) {
+ my $ignore = shift // [];
+ my @uid;
+
+ # invariant: we're at pos 8 + 4*(1+$#ignore + 1+$#uids) in the statefile
+ $IMAP->pull_new_messages($ATTRS, sub($) {
+ my $mail = shift;
+ return unless exists $mail->{RFC822}; # not for us
+
+ my $uid = $mail->{UID};
+ my $from = first { defined $_ and @$_ } @{$mail->{ENVELOPE}}[2,3,4];
+ $from = (defined $from and @$from) ? $from->[0]->[2].'@'.$from->[0]->[3] : '';
+ print STDERR "($MAILBOX): UID $uid from <$from> ($mail->{INTERNALDATE})\n" unless $CONFIG{quiet};
+
+ sendmail($from, $mail->{RFC822}) unless $CONFIG{'no-delivery'};
+
+ push @uid, $uid;
+ writeUID($uid);
+ }, @$ignore);
+
+ # terminate the SMTP transmission channel gracefully, cf RFC 5321 section 4.5.3.2
+ smtp_send('QUIT' => '221') if defined $SMTP;
+ undef $SMTP;
+
+ # now that everything has been deliverd, mark @ignore and @uid as \Seen
+ $IMAP->silent_store(compact_set(@$ignore, @uid), '+', '\Seen') if @$ignore or @uid;
+
+ # update the statefile
+ sysseek($STATE, 4, SEEK_SET) // die "Can't seek: $!";
+ my ($uidnext) = $IMAP->get_cache('UIDNEXT');
+ writeUID($uidnext);
+ truncate($STATE, 8) // die "Can't truncate";
+}
+
+do {
+ my $uidvalidity = readUID();
+ my $uidnext = readUID();
+ my $ignore = [];
+
+ $IMAP->set_cache($MAILBOX, UIDVALIDITY => $uidvalidity, UIDNEXT => $uidnext);
+ $IMAP->select($MAILBOX);
+
+ unless (defined $uidvalidity) {
+ ($uidvalidity) = $IMAP->get_cache('UIDVALIDITY');
+ # we were at pos 0 before the write, at pos 4 afterwards
+ writeUID($uidvalidity);
+ die if defined $uidnext; # sanity check
+ }
+
+ if (!defined $uidnext) {
+ # we were at pos 4 before the write, at pos 8 afterwards
+ writeUID(1);
+ }
+ else {
+ # put the remaining UIDs in the @ignore list: these messages
+ # have already been delivered, but the process exited before the
+ # statefile was updated
+ while (defined (my $uid = readUID())) {
+ push @$ignore, $uid;
+ }
+ }
+ pull($ignore);
+ purge();
+};
+unless (defined $CONFIG{idle}) {
+ $IMAP->logout();
+ exit 0;
+}
+
+$CONFIG{idle} = 1740 if defined $CONFIG{idle} and $CONFIG{idle} == 0; # 29 mins
+while(1) {
+ my $r = $IMAP->idle($CONFIG{idle}, sub() { $IMAP->has_new_mails($MAILBOX) });
+ pull() if $r;
+ purge();
+}