aboutsummaryrefslogtreecommitdiffstats
path: root/pullimap
diff options
context:
space:
mode:
Diffstat (limited to 'pullimap')
-rwxr-xr-xpullimap173
1 files changed, 173 insertions, 0 deletions
diff --git a/pullimap b/pullimap
new file mode 100755
index 0000000..d1a2f4a
--- /dev/null
+++ b/pullimap
@@ -0,0 +1,173 @@
+#!/usr/bin/perl -T
+
+#----------------------------------------------------------------------
+# Pull mails from an IMAP mailbox and deliver them to an 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 Fcntl qw/O_CREAT O_RDWR O_DSYNC LOCK_EX SEEK_SET/;
+use Getopt::Long qw/:config posix_default no_ignore_case gnu_getopt auto_version/;
+use List::Util 'first';
+
+use lib 'lib';
+use Net::IMAP::InterIMAP 'read_config';
+
+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/);
+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/
+ )->{$ARGV[0]};
+
+my ($MAILBOX, $STATE, $LOGGER_FD);
+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: $!";
+ flock($STATE, LOCK_EX) or die "Can't flock $statefile: $!";
+
+
+ if (defined (my $logfile = $CONF->{logfile})) {
+ require 'POSIX.pm';
+ require 'Time/HiRes.pm';
+ open $LOGGER_FD, '>>', $logfile or die "Can't open $logfile: $!\n";
+ $LOGGER_FD->autoflush(1);
+ }
+ elsif ($CONFIG{debug}) {
+ $LOGGER_FD = \*STDERR;
+ }
+};
+
+
+#######################################################################
+
+# 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: $!"
+ ) {}
+}
+
+
+#######################################################################
+# Initialize the cache from the statefile, then pull new messages from
+# the remote mailbox
+#
+my $IMAP = Net::IMAP::InterIMAP::->new( %$CONF, %CONFIG{qw/quiet debug/}, 'logger-fd' => $LOGGER_FD );
+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 {
+ while (defined (my $uid = readUID())) {
+ push @ignore, $uid;
+ }
+ }
+
+ my $attrs = join ' ', qw/ENVELOPE INTERNALDATE BODY.PEEK[]/;
+ my @uid;
+
+ # invariant: we're at pos 8 + 4*(1+$#ignore + 1+$#uids)
+ $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};
+
+ # TODO sendmail
+ push @uid, $uid;
+ writeUID($uid);
+ }, @ignore);
+
+ # TODO mark (@ignore, @uid) as seen
+
+ # update the statefile
+ sysseek($STATE, 4, SEEK_SET) // die "Can't seek: $!";
+ ($uidnext) = $IMAP->get_cache('UIDNEXT');
+ writeUID($uidnext);
+ truncate($STATE, 8) // die "Can't truncate";
+};