diff options
Diffstat (limited to 'pullimap')
| -rwxr-xr-x | pullimap | 173 |
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"; +}; |