Qmail::Deliverable - Determine deliverability of local addresses

    use Qmail::Deliverable ':all';

    return DECLINED if not qmail_local $recip;
    return DECLINED if deliverable $recip;
    return DENY, "Who's that?";

    my $dot_qmail_filename = dot_qmail 'foo@example.com';

    vpopmail domain, vuser with top level dir   11000/s
    vpopmail domain, valias exists               1500/s
    vpopmail domain, vuser with hashed dir       1400/s
    vpopmail domain, address unknown             1400/s
    local, user listed in users/assign          15000/s
    local, user exists, not listed               2000/s
    local, user unknown                          1800/s
    experimental caching enabled               200000/s

package Qmail::Deliverable;

use strict;
use 5.006;
use Carp qw(carp);
use base 'Exporter';

our $VERSION = '1.06';
our @EXPORT_OK = qw/reread_config qmail_local dot_qmail deliverable qmail_user/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);

# rfc2822's "atext"
my $atext = "[A-Za-z0-9!#\$%&\'*+\/=?^_\`{|}~-]";
my $valid = qr/^(?!.*\@.*\@)($atext+(?:[\@.]$atext+)*)\.?\z/;

# disallow control characters and non-ascii
my $ascii = qr/^([\x20-\x7e]*)\z/;

# parse shell line
my $shell_sq = qr/'[^']+'/;  # no escaping in single quotes!
my $shell_dq = qr/(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))/;  # from Regexp::Common
my $shell_bare = qr/[^"'\\\s]+/;  # no sq, dq, backslash, or space
my $shell_token = qr/(\\.|$shell_sq|$shell_dq|$shell_bare)+/;

sub _readpipe {
    my ($command, @args) = @_;
    local %ENV = ();
    open my $fh, '-|', $command, @args or die "open: @_: $!";
    my @data = readline $fh;
    close $fh;  # Without explicit close, $? is unreliable later
    return wantarray ? @data : join("", @data);
}

sub _slurp {
    my ($fn) = @_;
    open my $fh, '<', $fn or return;
    return wantarray ? readline $fh : join("", readline $fh);
}

sub _first (&@) {
    my $sub = shift;
    $sub->($_) and return $_ for @_;
    return;
}

sub _findinpath {
    my ($command) = @_;
    # Attempt to retain some level of security against PATH attacks
    my @path = grep defined, map /($ascii)/,  # untaint
        grep m{^/[^<>|]+$}, split /:/, $ENV{PATH};
    return _first { -x $_ } map "$_/$command", @path;
}

# Resolve only once to further reduce risk of PATH attacks
my $valias_exec = _findinpath 'valias';
my $vuser_exec = _findinpath 'vuserinfo';

my %locals;
my %virtualdomains;
my %users_exact;
my %users_wild;

sub reread_config {
    %locals         = ();
    %virtualdomains = ();
    %users_exact    = ();
    %users_wild     = ();
    my $locals_fn = -e "/var/qmail/control/locals"
        ? "/var/qmail/control/locals"
        : "/var/qmail/control/me";
    for (_slurp $locals_fn) {
        chomp;
        ($_) = lc =~ /$ascii/ or do { warn "Invalid character"; next; };
        $locals{$_} = 1;
    }
    for (_slurp "/var/qmail/control/virtualdomains") {
        chomp;
        ($_) = lc =~ /$ascii/ or do { warn "Invalid character"; next; };
        my ($domain, $prepend) = split /:/, $_, 2;
        $virtualdomains{$domain} = $prepend;
    }
    for (_slurp "/var/qmail/users/assign") {
        chomp;
        ($_) = /$ascii/ or do { warn "Invalid character"; next; };
        if (s/^=([^:]+)://) {
            $users_exact{lc $1} = $_;
        } elsif (s/^\+([^:]+)://) {
            $users_wild{lc $1} = $_;
        } elsif (/^\.$/) {
            last;
        } else {
            warn "Invalid line in users/assign: '$_'\n";
        }
    }
}

sub _qmail_getpw {
    my ($local) = @_;
    local $/ = "\0";
    my @a = _readpipe "/var/qmail/bin/qmail-getpw", $local;
    chomp @a;
    for (@a) {
        ($_) = /$ascii/ or do { warn "Invalid character"; return ""; }
    }
    return @a;
}

sub _prepend {
    my ($domain) = @_;

    return $virtualdomains{$domain} if exists $virtualdomains{$domain};

    my @parts = split /\./, $domain;
    for (reverse 1 .. @parts) {
        my $wildcard = join "", map ".$_", @parts[-$_ .. -1];
        return $virtualdomains{$wildcard} if exists $virtualdomains{$wildcard};
    }

    return $virtualdomains{''} if exists $virtualdomains{''};
    return undef;
}

sub _potential_exts {
    my ($ext) = @_;
    my @exts;

    # Exact match has highest precedence
    push @exts, $ext;

    # Then foo-default
    my @parts = split /(-)/, $ext;
    for (reverse 1 .. $#parts) {
        next unless $parts[$_] eq '-';
        push @exts, join("", @parts[0..$_]) . "default";
    }

    # Then catch all
    push @exts, "default";

    return @exts;
}


sub qmail_user {
    my ($in) = @_;
    my ($local) = lc($in) =~ /$valid/
        or do { carp "Invalid address: $in"; return; };

    if (exists $users_exact{$local}) {
        return split /:/, $users_exact{$local}, 7;  # colon terminated
    } else {
        for (reverse 1 .. length $local) {
            my $try = substr $local, 0, $_;
            if (exists $users_wild{$try}) {
                my @assign = split /:/, $users_wild{$try}, 7;
                $assign[5] = substr($local, $_) . $assign[5];
                return @assign;
            }
        }
    }

    return _qmail_getpw $local;
}

sub qmail_local {
    my ($in) = @_;
    my ($address) = lc($in) =~ /$valid/ or
        do { carp "Invalid address: $in"; return; };

    return $address if $address !~ /\@/;
    my ($local, $domain) = split /\@/, $address;

    return $local if exists $locals{$domain};

    my $prepend = _prepend $domain;
    return "$prepend-$local" if defined $prepend;

    return undef;
}

sub dot_qmail {
    my ($user, $uid, $gid, $homedir, $dash, $ext) = @_;
    if (@_ == 1) {
        my ($in) = @_;
        my ($address) = lc($in) =~ /$valid/
            or do { carp "Invalid address: $in"; return; };

        my $local = qmail_local $address;
        return undef if not defined $local;

        ($user, $uid, $gid, $homedir, $dash, $ext) = qmail_user $local;
    }

    $ext =~ s/\./:/g;

    my $dashext = $dash . $ext;

    if (not length $dashext) {
        return "$homedir/.qmail" if -e "$homedir/.qmail";
        return "";  # defaultdelivery
    }

    for (_potential_exts $ext) {
        return "$homedir/.qmail-$_" if -e "$homedir/.qmail-$_";
    }

    return undef;
}

sub valias {
    my ($address) = @_;
    if (not $valias_exec) {
        warn "Cannot check valias; valias executable not found";
        return 0;
    }
    my ($local, $domain) = split /\@/, $address;
    my $counter = 0;
    for (_potential_exts $local) {
        eval { _readpipe $valias_exec, "$_\@$domain" };
        return ++$counter if $? == 0;
    }
    return 0;
}

sub vuser {
    my ($address) = @_;
    if (not $vuser_exec) {
        warn "Cannot check vuser; vuser executable not found";
        return 0;
    }
    eval { _readpipe $vuser_exec, $address } or return 0;
    return 1 if $? == 0;
    return 0;
}

sub deliverable {
    my ($in) = @_;
    my ($address) = lc($in) =~ /$valid/
        or do { carp "Invalid address: $in"; return; };

    my $local = qmail_local $address;
    return 0xff if not defined $local;

    my ($user, $uid, $gid, $homedir, $dash, $ext)
        = qmail_user $local;

    return 0x11 if not -r $homedir or not -x _;
    return 0x21 if (stat _)[2] & 0020;  # group writable
    return 0x21 if (stat _)[2] & 0002;  # world writable
    return 0x22 if -T _;

    my $dot_qmail = dot_qmail $user, $uid, $gid, $homedir, $dash, $ext;

    return 0x00 if not defined $dot_qmail;
    return 0xf1 if not length $dot_qmail;  # no .qmail => defaultdelivery

    return 0x00 if not -e $dot_qmail;
    return 0x11 if not -r $dot_qmail;
    return 0xf1 if not -s _;  # empty => defaultdelivery

    my @dot_qmail = _slurp $dot_qmail;

    if ($dot_qmail[0] =~ /^\|\s*\S*vdelivermail/) {
        if ($address !~ /\@/) {
            carp "vpopmail support not available if no domain given";
            return 0xfe;
        }
        my $origlocal = (split /\@/, $address)[0];

        # Update domain with user field in assign file, just like vpopmail
        # does. This way we support alias domains. See vpopmail.c,
        # vget_assign().
        $address = $origlocal . '@' . $user;

        if ($dot_qmail[0] =~ /bounce-no-mailbox/) {
            return 0xf2 if -d "$homedir/$origlocal";
            return 0xf3 if valias $address;
            return 0xf2 if vuser $address;
            return 0x00;
        }
        return 0xf4;
    }
    if ($dot_qmail[0] =~ /^\|bouncesaying\s+(.*)/) {
        my @args = $1 =~ /$shell_token/g;
        return 0x13 if @args > 1;
        return 0x00;
    }

    return 0x12 if grep /^\|/, @dot_qmail;

    return 0xf1;
}

reread_config;

# use Memoize;
# use Memoize::Expire;
# tie my %deliverable_cache, 'Memoize::Expire', LIFETIME => 60;
# memoize 'deliverable';

1;

__END__