#!/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 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/);
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 {
        # 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;
        }
    }

    # use BODY.PEEK[] so if something gets wrong, unpulled messages
    # won't be marked as \Seen in the mailbox
    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);

    # 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: $!";
    ($uidnext) = $IMAP->get_cache('UIDNEXT');
    writeUID($uidnext);
    truncate($STATE, 8) // die "Can't truncate";
};