#!/usr/bin/perl
#
# qdc.pl (Qmail Delivery Check)
#
# Copyright (C) 2004 by Zachary Beane <xach@xach.com>
#
# Explores the delivery path of one or more email addresses and
# prints the result. This is highly specific to the qmail delivery
# system.
#
# It assumes qmail files live in /var/qmail (the standard location).
#
# This script is not quite correct. It doesn't strictly check
# that +x ~/.qmail files contain only pipe targets.
#
# 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 2 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, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
# $Id: qdc.pl,v 1.16 2004/09/01 18:59:27 xach Exp $

use File::stat;
use strict;
use CDB_File;
use Sys::Syslog qw(:DEFAULT setlogsock);

my $progname = "qdc";

if ($> != 0) {
    print STDERR "$progname: This program must be run as root.\n";
    exit(1);
}


setlogsock("unix");
openlog($progname, 'pid', 'mail');
syslog('notice', join(" ", ($0, @ARGV)));

while ($ARGV[0] =~ /^-/) {
    my $option = shift(@ARGV);
    if ($option eq "-v") {
	enable_trace();
    }
}

if (scalar @ARGV == 0) {
    print STDERR "usage: $progname [-v] ADDRESS [ADDRESS2 ADDRESS3 ...]\n";
    print STDERR "Adding -v will provide debugging output.\n";
    exit(1);
}

# lowercase all arguments
my @addresses = map { lc } @ARGV;

foreach my $lookup (@addresses) {
    print "$lookup:\n";

    my @rcpt = qmail_send($lookup);
    foreach my $rcpt (@rcpt) {
	print " $rcpt\n";
    }

    if (scalar @rcpt == 0) {
	print " $lookup: Mail to this user will bounce\n";
    }
}

closelog();
exit(0);


#######################################################

#
# find_dot_qmail tries to find the appropriate .qmail file, given
# a starting directory and an extension. 
# 
# dot-qmail(5)
#

sub find_dot_qmail {
    my ($dir, $dash, $ext) = @_;
    my $default = $ext;

    # from dot-qmail(5): extension is lowercased and dots are converted
    # to colons
    $ext =~ s/\./:/g;
    $ext = lc($ext);

    my $testfile = $dir . "/.qmail" . $dash . $ext;
    trace("$testfile");
    if (-e $testfile) {
	return $testfile;
    }

    if (!$dash) {
	return "";
    }

    if ($ext !~ /$dash/) {
	my $testfile = $dir . "/.qmail" . $dash . "default";
	trace("$testfile");
	if (-e $testfile) {
	    trace("default is $default");
	    $ENV{DEFAULT} = $default;
	    return $testfile;
	} else {
	    return "";
	}
    }

    my @ext_parts = split($dash, $ext);
    $default = $ext_parts[-1];

    do {
	@ext_parts[-1] = "default";

	my $testext = join($dash, @ext_parts);
	my $testfile = $dir . "/.qmail" . $dash . $testext;

	trace("$testfile");

	if (-e $testfile) {
	    $ENV{DEFAULT} = $default;
	    return $testfile;
	}

	pop(@ext_parts);
	$default = $ext_parts[-1] . $dash . $default;
	trace($default);
    } while (scalar @ext_parts > 0);

    return "";
}


#
# qmail_send examines an address to see if it should be handled locally.
# It checks for the domain in the QMAILDIR/control/locals file and
# the address or domain in the QMAILDIR/control/virtualdomains file.
#
# If the address should be locally handled, it returns the results
# qmail_lspawn.  Otherwise, it returns the address with a description
# prepended to it.
#

@MAIN::addr_stack = ();
	
sub qmail_send {
    my ($address) = @_;
    my @retval;
    local(%ENV);

    traceup();
    
    if ($address !~ /\@/) {
	$address .= "\@" . (qmail_control_file("defaultdomain") || qmail_me());
    }

    trace("$address");


    # XXX the loop checking needs cleanup. It would be better
    # to track the path with a hidden lexical (a la the trace function
    # family) rather than a global.

    if (in_array($address, @MAIN::addr_stack)) {
	mywarn("Mail loop encountered [",
	       join(" => ", (@MAIN::addr_stack, $address)),
	       "]");
	return ();
    } else {
	push(@MAIN::addr_stack, $address);
	trace("Path so far: [",
	      join(" => ", @MAIN::addr_stack),
	      "]");
    }

    my ($username, $domain) = split(/\@/, $address);

    #
    # %ENV is used for variable expansion of pipes in .qmail files.
    # See qmail-command(8).
    #

    $ENV{RECIPIENT} = $address;
    $ENV{LOCAL}     = $username;
    $ENV{HOST}      = $domain;

    
    if (in_locals_p($domain)) {
	@retval = qmail_lspawn($username, $address);
    } elsif (my $virtuser = virtualdomains_lookup($address)) {
	@retval = qmail_lspawn($virtuser . "-" . $username, $address);
    } elsif (my $virtuser = virtualdomains_lookup($domain)) {
	@retval = qmail_lspawn($virtuser . "-" . $username, $address);
    } else {
	@retval = ("Remote address $address");
    }

    tracedown();

    pop(@MAIN::addr_stack);
    return @retval;
}


#
# qmail_local handles local delivery. It checks the contents of
# .qmail files.
#
# If no .qmail files are present, it treats the username as the final
# recipient.
#
# If a .qmail file is present, it checks each line of the file:
#
#    - If the line starts with a / or a ., it treats the line as
#      a final recipient mailbox
#    - If the line starts with a |, it treats the line as a pipe
#      recipient and tries to resolve fastforward and forward addresses
#    - Otherwise, treat the line as a new address and start a new
#      qmail_send process on it
#

sub qmail_local {
    my ($username, $dir, $dash, $ext, $orig_address) = @_;
    my @retval;

    $ENV{USER}     = $username;
    $ENV{EXT}      = $ext;
    $ENV{HOME}     = $dir;

    trace("$username $dir $dash $ext");


    #
    # Check for lax permissions on the home directory
    #

    my $homedir_mode = stat($dir)->mode();

    if ($homedir_mode & 01000) {
	mywarn("$dir is mode +t, deferring");
	return ();
    }

    if ($homedir_mode & 0002) {
	mywarn("$dir is world-writable, deferring");
	return ();
    }

    if ($homedir_mode & 0020) {
	mywarn("$dir is group-writable, deferring");
	return ();
    }


    #
    # Load the ~/.qmail file, if it exists
    #

    my $dotqmailfile = find_dot_qmail($dir, $dash, $ext);

    if ($dotqmailfile) {
	my @dotqmailrcpts = dot_qmail_recipients($dotqmailfile);
	foreach my $address (@dotqmailrcpts) {
	    if ($address =~ /^[a-z0-9]/i) {
		push(@retval, qmail_send($address));
	    } elsif ($address =~ /^\./) {
		$address =~ s/^\./$dir/;
		push(@retval, "Local mailbox $address");
	    } elsif ($address =~ /^\//) {
		push(@retval, "Local mailbox $address");
	    } elsif ($address =~ /^\|/) {
		# Handle pipes; this is where fastforward aliasing
		# gets expanded
		push(@retval, try_pipe($address, $orig_address));
	    } else {
		push(@retval, "Unknown recipient $address");
	    }

	}
	return @retval;
    } else {
	if ($ext) {
	    return ();
	} else {
	    return ("Local user $username (default mailbox in $dir)");
	}
    }
}



#
# qmail_lspawn looks up user information in either the qmail-users
# facility or the qmail-getpw facility and calls qmail_local on the
# returned values.
#

sub qmail_lspawn {
    my ($username, $address) = @_; 

    trace("trying $username");
    if (my ($name, $uid, $gid, $dir, $dash, $ext) = qmail_users_lookup($username)) {
	# setuid & setgid to the target user
	local $> = $uid;
	local $) = $gid;
	return qmail_local($username, $dir, $dash, $ext, $address);
    } elsif (my ($name, $uid, $gid, $dir, $dash, $ext) = etc_passwd_lookup($username)) {
	# setuid & setgid to the target user
	local $> = $uid;
	local $) = $gid;
	return qmail_local($username, $dir, $dash, $ext, $address);
    } else {
	mywarn("User not found and no alias user found!");
	return;
    }
}


    
#
# qmail_users_lookup returns a list of ($name, $uid, $gid, $dir, $dash, $ext)
# if the user is in the QMAILDIR/users/assign database, or an empty
# list otherwise.
#

sub qmail_users_lookup {
    my ($username) = @_;
    my %assign;

    my $key = "!$username\0";
    
    tie %assign, 'CDB_File', '/var/qmail/users/cdb'
	or return ();

    my $dash = "";
    my $ext = "";

    trace("looking for $username in the assign file");

    if (exists($assign{$key})) {
	my ($name, $uid, $gid, $dir) = split(/\0/, $assign{$key});
	if (homedir_owner_good_p($uid, $dir, $username)) {
	    return ($name, $uid, $gid, $dir, $dash, $ext);
	} else {
	    return ();
	}
    }

    # Wildcard resolution
    if (!exists($assign{""}) || $assign{""} eq "") {
	trace("not found");
	return ();
    }

    my $dash = $assign{""};

    # 
    # Try to find a matching wildcard by removing parts after the dash.
    #
    
    my @local_parts = split(/$dash/, $username);
    $ext = $local_parts[-1];

    do {
	$local_parts[-1] = "";
	my $key = join($dash, @local_parts);

	trace("trying [$key]");

	$key = "!$key";

	if (exists($assign{$key})) {
	    trace("found");
	    my ($name, $uid, $gid, $dir, $dash, $pre) = split(/\0/, $assign{$key});
	    if (homedir_owner_good_p($uid, $dir, $username)) {
		return ($name, $uid, $gid, $dir, $dash, $pre . $ext);
	    }
	}

	pop(@local_parts);
	$ext = $local_parts[-1] . $dash . $ext;
    } while (scalar @local_parts > 0);

    return ();
}


#
# etc_passwd_lookup checks for users in /etc/passwd and returns a list
# of ($name, $uid, $gid, $dir, $dash, $ext) if the user's information
# can be determined. Includes checking for the "alias" user as a final
# case.
#
# XXX This should exec qmail-getpw for its results instead of doing the
# lookup directly.
#

sub etc_passwd_lookup {
    my ($username) = @_;
    
    my $dash = "";
    my $ext = "";

    trace("looking up $username");

    if (my @pwent = getpwnam($username)) {
	my ($uid, $gid, $dir) = @pwent[2,3,7];
	if ($uid != 0 && homedir_owner_good_p($uid, $dir, $username)) {
	    return ($username, $uid, $gid, $dir, $dash, $ext);
	} else {
            $dash = "-";
            goto ALIASLOOKUP;
	}
    }

    $dash = "-";

    if ($username =~ /$dash/) {
	my ($new_username, $ext) = split(/$dash/, $username, 2);

	if (my @pwent = getpwnam($new_username)) {
	    my ($uid, $gid, $dir) = @pwent[2,3,7];
	    if ($uid != 0 && homedir_owner_good_p($uid, $dir, $new_username)) {
		return ($new_username, $uid, $gid, $dir, $dash, $ext);
	    }
	}
    }

  ALIASLOOKUP:
    if (my @pwent = getpwnam("alias")) {
	my ($uid, $gid, $dir) = @pwent[2,3,7];
	return ("alias", $uid, $gid, $dir, $dash, $username);
    }

    return ();
}


#
# dot_qmail_recipients returns a list containing the contents of 
# a .qmail-formatted file. Email addresses have the leading "&" removed,
# comment lines starting with "#" and empty lines are omitted, all
# other lines are returned verbatim.
#

sub dot_qmail_recipients {
    my ($dotfile) = @_;
    my @retval;

    if (!-e $dotfile) {
	return ();
    }


    # Check for bogus modes on the .qmail file
    my $mode = stat($dotfile)->mode();

    if ($mode & 0020) {
	mywarn("$dotfile is group-writable and will be ignored");
	return ();
    }

    if ($mode & 0002) {
	mywarn("$dotfile is world-writable and will be ignored");
	return ();
    }
    

    if (!open(F, "<$dotfile")) {
	mywarn("$dotfile exists but is unreadable");
	return ();
    }

    while (my $line = <F>) {
	chomp($line);
	next if $line =~ /^\s*#/;
	next if $line =~ /^\s*$/;

	$line =~ s/^&//;
	push(@retval, $line);
	trace("$dotfile: $line");
    }

    close(F);

    return @retval;
}
    

#
# get_aliases returns a list of values associated with a particular
# key in a qmail fastforward alias database. It follows the fastforward
# alias resolution algorithm in that the initial lookup allows for
# wildcard (@domain and username@) matches, but recursive lookups
# of the values only match exactly.
#

sub get_aliases {
    my ($address, $alias_file) = @_;
    my @retval;

    if (!-e $alias_file) {
	return ();
    }

    foreach my $result (getalias_wild($address, $alias_file)) {
	push(@retval, getalias_recurse($result, $alias_file));
    }

    return @retval;
}


#
# getalias_wild is a helper subroutine for get_aliases
#

sub getalias_wild {
    my ($address, $file) = @_;
    my @retval = ();

    traceup();

    my %a;
    tie %a, 'CDB_File', $file
	or return ();

    my ($username, $domain) = split(/\@/, $address);

    # For a given username@domain, check for username@domain, @domain, 
    # username@, per setforward(1)

    my $exact      = "$username\@$domain";
    my $domainwild = "\@$domain";
    my $userwild   = "$username\@";

    foreach my $key ($exact, $domainwild, $userwild) {
	if (exists($a{":$key"})) {
	    @retval = split(/\0/, $a{":$key"});
	    trace("$file: $key => @retval");
	    last;
	} else {
	    trace("$file: $key => no match");
	}
    }

    untie %a;

    tracedown();

    return @retval;
}


#
# getalias_recurse is a helper subroutine for get_aliases
#
# setforward(1)
#

%MAIN::_aliases_seen = ();

sub getalias_recurse {
    my ($address, $file) = @_;
    my @retval;

    my %a;
    tie %a, 'CDB_File', $file
	or return ();

    $address =~ s/^&//;

    if (exists($MAIN::_aliases_seen{$address})) {
	mywarn("Aliasing loop for $address => " . 
	       $MAIN::_aliases_seen{$address});
	return ();
    }

    traceup();


	


    trace("getalias: $address");

    if (exists($a{":$address"})) {
	my @targets = split(/\0/, $a{":$address"});
	$MAIN::_aliases_seen{$address} = join(", ", @targets);
	@retval = map { 
	    getalias_recurse($_, $file);
	} @targets;
    } else {
	@retval = ($address);
    }

    untie %a;

    tracedown();

    return @retval;
}


#
# qmail_control_file FILENAME
#
# Return the first line of a qmail control file in /var/qmail/control,
# or an empty string if the file does not exist.
#

sub qmail_control_file {
    my ($file) = @_;
    my $full_path = '/var/qmail/control/' . $file;

    if (!-e $full_path) {
	return "";
    }

    if (!open(F, "<$full_path")) {
	return "";
    }

    my $retval = <F>;
    close(F);
    chomp($retval);

    return $retval;
}
    

#
# qmail_me returns the first line of the QMAILDIR/control/me file. qmail
# uses "me" as the default domain for certain purposes.
#

sub qmail_me {
    open(F, "/var/qmail/control/me")
	or return undef;
    
    my $retval = <F>;
    close(F);
    chomp($retval);

    return $retval;
}


#
# in_locals_p returns 1 if the specified domain is in QMAILDIR/control/locals,
# 0 otherwise. qmail does not deliver locally to domains not listed in the
# locals or virtualdomains file.
#

sub in_locals_p {
    my ($domain) = @_;
    my $locals = "/var/qmail/control/locals";
    my $me = "/var/qmail/control/me";

    if (!-e $locals) {
	$locals = $me;
    }

    open(L, "<$locals")
	or return 0;

    while (my $line = <L>) {
	chomp($line);
	if (lc($line) eq lc($domain)) {
	    close(L);
	    return 1;
	}
    }

    close(L);
    return 0;
}



$MAIN::_vdom_cache = ();
$MAIN::_vdom_cache_initialized = 0;


#
# virtualdomains_lookup returns the value for the specified key in
# the QMAILDIR/control/virtualdomains file, or an empty string otherwise.
#
# Matching of the left-hand side is case-insensitive; eXample.com, 
# EXAMPLE.COM, and example.com are equivalent.
#

sub virtualdomains_lookup {
    my ($key) = map { lc } @_;

    trace("looking up $key in virtualdomains");

    if (!$MAIN::_vdom_cache_initialized) {
	$MAIN::_vdom_cache_initalized = 1;

	if (-e "/var/qmail/control/virtualdomains") {
	    open(V, "</var/qmail/control/virtualdomains");
	    while (my $line = <V>) {
		chomp($line);
		my ($vkey, $vvalue) = split(/:/, $line);
		$MAIN::_vdom_cache{lc($vkey)} = $vvalue;
	    }
	    close(V);
	}
    }

    if (exists($MAIN::_vdom_cache{$key})) {
	trace("found");
	return $MAIN::_vdom_cache{$key};
    } else {
	trace("not found");
	return "";
    }
}


#
# try_pipe tries to convert a .qmail-file pipe target to a real email
# address. It knows how to handle pipes to the "fastforward" command
# and follow fastforward aliases. It knows how to handle pipes to the
# "forward".
#
# Before processing the pipe, it tries to substitute environment variables
# as the shell would, using variables explained in qmail-command(8). The
# full list of qmail-command variables is not completely implemented.
#
# If try_pipe doesn't know how to follow the pipe, it returns the pipe
# line with a description prepended to it.
#

sub try_pipe {
    my ($pipe, $address) = @_;
    my @retval;

    $pipe = shellexpand($pipe, %ENV);
    trace("$pipe");

    if ($pipe =~ /^\|.*fastforward.* (\S+)$/) {
	foreach my $alias (get_aliases($address, $1)) {
	    if ($alias =~ /^[a-z0-9]/i) {
		push(@retval, qmail_send($alias));
	    } else {
		push(@retval, "Aliased to $alias");
	    }
	}
	return @retval;
    } elsif ($pipe =~ /^\|.*\bforward (.*)$/) {
	my @addrs = split(/\s/, $1);
	my @retval = ();

	foreach my $addr (@addrs) {
	    push(@retval, qmail_send($addr));
	}
	
	return @retval;
    } else {
	return "Pipe $pipe";
    }
}


#
# homedir_owner_good_p returns 1 if $uid owns $dir; it prints
# a warning and returns 0 otherwise.
#

sub homedir_owner_good_p {
    my ($uid, $dir, $username) = @_;

    my $st = stat($dir);

    if (!$st) {
	mywarn("homedir for $username ($dir) does not exist");
	return 0;
    }


    if ($st->uid == $uid) {
	return 1;
    } else {
	mywarn("$username (uid $uid) does not own homedir $dir");
	return 0;
    }
}
	


#
# shell_read_varname.
#
# Helper procedure for shellexpand.
#
# Given a string and a starting point, read characters until
# reaching a character not allowed in a shell variable. Also
# understands curly-brace syntax, i.e. ${FOO}.
#
# Returns the variable name and the number of characters read to
# get it.
#
#  shell_read_varname('$foo bar', 0)    => ('foo', 4)
#  shell_read_varname('${foo} bar', 0)  => ('foo', 6)
#
# This procedure isn't too smart about badly-formed variables.
#

sub shell_read_varname {
    my ($str, $start_char) = @_;
    my $varname = "";
    my $skip_count = 0;


    my $substr = substr($str, $start_char);
    my @chars = split(//, $substr);

    # Take out the leading "$"
    shift(@chars);

    # "$" at end of str
    if (scalar $#chars == 0) {
	return ($varname, $skip_count);
    }

    my $bracket_p = 0;
    if ($chars[0] eq "{") {
	$bracket_p = 1;
	shift(@chars);
	$skip_count++;
    }

    # Read until non-alphanumeric
    while ($#chars >= 0 && $chars[0] =~ /[A-Za-z0-9_]/) {
	$varname .= shift(@chars);
	$skip_count++;
    }

    if ($bracket_p && scalar @chars > 0) {
	if ($chars[0] eq "}") {
	    $skip_count++;
	}
    }

    return ($varname, $skip_count);
}
    

#
# shellexpand
#
# Given a string and an environment hash, attempt to do shell-style
# substitution and return the resulting string.
#
#    shellexpand('|forward ${DEFAULT}',
#                DEFAULT => "bob")       => '|forward bob'
#
# This subroutine is not as strict as real shell substitution. Invalid
# shell variables may get expanded unexpectedly.
#

sub shellexpand {
    my($cmd, %env) = @_;
    my $output;

    my @chars = split(//, $cmd);
    for (my $i = 0; $i <= $#chars; $i++) {
	if ($chars[$i] eq "\\") {
	    $output .= $chars[$i];
	    if (($i + 1) < $#chars) {
		$output .= $chars[$i + 1];
		$i++;
	    }
	    next;
	}

	if ($chars[$i] eq "\$") {
	    my ($var, $skip_count) = shell_read_varname($cmd, $i);
	    if (exists($env{$var})) {
		$output .= $env{$var};
	    }

	    $i += $skip_count;
	    next;
	}

	$output .= $chars[$i];
    }

    return $output;
}


#
# Tracing output; put in its own block to lexically scope the variables
# it uses.
#

{
    my $trace_p;
    my $tracelevel;

    sub enable_trace {
	$trace_p = 1;
    }


    sub disable_trace {
	$trace_p = 0;
    }
    

    sub traceup {
	$tracelevel++;
    }


    sub tracedown {
	$tracelevel--;
    }

    sub trace {
	return unless $trace_p;
        my $calling_sub = (caller(1))[3];
        $calling_sub =~ s/.*:://;
        print "  " x $tracelevel;
        printf("[%02d] $calling_sub: ", $tracelevel);
	print @_, "\n";
    }
}


#
# Utility stuff
#

sub in_array {
    my ($obj, @array) = @_;

    foreach my $elt (@array) {
	if ($obj eq $elt) {
	    return 1;
	}
    }

    return 0;
}


sub mywarn {
    my $message = join("", @_);
    syslog('err', $message);
    print STDERR "Warning: $message\n";
}


__END__

=head1 NAME

qdc - the qmail delivery checker

=head1 SYNOPSIS

B<qdc> [I<-v>] I<EMAIL-ADDRESS> [I<EMAIL-ADDRESS>]...

=head1 DESCRIPTION

Display the final destinations for the given EMAIL-ADDRESSes. If any
address does not have a domain part, the first line of
/var/qmail/control/me is appended to it.

=head1 OPTIONS

=over 4

=item B<-v>

display extra debugging information while looking up the delivery
path.

=back

=head1 AUTHOR

Zachary Beane <xach@xach.com>