: # -*- perl -*-
eval 'exec perl -w -S $0 ${1+"$@"}' # Let `sh' locate `perl'
    if 0;

# Copyright 1999, 2000, 2001, 2002 Stefan Merten

# 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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

# Base on Id: sample.pl,v 3.2 1999/03/29 15:40:43 stefan Exp

=head1 NAME

valiases - Redistribute mail send to a virtual mail address

=head1 SYNPOSIS

B<valiases> [I<option>]... [I<domain> I<aliases>]...

B<valiases> [I<option>]... B<-d> I<alias-dir> [I<domain>]...

B<valiases> B<-H>

=head1 DESCRIPTION

B<valiases> may be used to set up virtual mail addresses pointing to a real
mail address being permanently under service. By using B<valiases> the real
mail address may then resend the incoming mail as it would have been done by a
B<sendmail> running the virtual domain. This is useful if you have no access to
F</etc/aliases> file on a machine connected to the Internet permanently.

See L<"USING A LOCAL MAJORDOMO"> for some notes on using a local majordomo
installation with B<valiases>.

During normal operation B<valiases> expects a mail on F<stdin>. It analyzes the
mail for occurences of a virtual mail address. B<valiases> considers a mail
address virtual if it is in the domain I<domain> and uses the local part of one
of the aliases defined in I<aliases> for that domain. For each virtual mail
address found, B<valiases> redistributes the mail using B<sendmail> using the
alias file I<aliases>.

The virtual mail addresses are searched in the C<To:> and C<Cc:> header fields
of the original mail. If any C<Redist-To:> and C<Redist-Cc:> header fields in
the mail exist, these are considered instead of the normal header fields.

B<valiases> adds a header line to the redistributed mail which allows to detect
loops. B<valiases> will not process a mail for a virtual mail address in
I<domain> more than once even if it is received again.

=head1 OPTIONS

=over 4

=item B<-c>

=item B<--check>

Instead of normal operation check all I<aliases> files for correctness. This
includes checks for command and file aliases.

The mapping contained in the alias files is put to a log file if one is given.

=cut

my $chkAlis = 0;

=item B<-d> I<alias-dir>

=item B<--alias-dir=>I<alias-dir>

If this option is given all alias files are expected in I<alias-dir> and named
after the domain I<domain> they apply to.

=cut

my $alisD = "";

=item B<-i>

=item B<--ignore-redist>

Ignore C<Redist-To> and C<Redist-Cc> header fields.

=cut

my $ignRedist = 0;

=item B<-l> I<log>

=item B<--log=>I<log>

Log all operations by appending to file I<log>. If this is not given all
operations are performed silently.

=cut

my $logF = "";

=item B<-p> I<lines>

=item B<--purge>=I<lines>

Purges first I<lines> C<Received:> lines in the header. If I<lines> is C<0>,
all C<Received:> lines so far are purged.

This option is useful since too many C<Received:> lines may cause a mail agent
to fail with C<Too many hops>. However, purging C<Received:> lines always cuts
some debugging possiblities so your milage may vary.

How many lines to purge depends on your setup. The most useful number seems to
be the number of C<Received:> lines put in the mail on behalf of delivery to
the real mail address instead of the virtual mail address. In my case this
number is C<4>.

=cut

my $prgLns;

=item B<-r> I<real-address>

=item B<--received=>I<real-address>

In addition to looking at the C<To:>, C<Cc:> and perhaps C<Redist-To:>,
C<Redist-Cc:> header lines, consider the C<Received:> lines. I<real-address>
has to be the real address used for feeding B<valiases>.

Each C<Received:> line is checked for a mail address. If a C<Received:> line is
found with mail address I<real-address>, the first following C<Received:> line
with a different mail address is also used as a candidate for a virtual mail
address. This address should be the original envelope address.

This feature works best (or at all) if the site where the virtual mail address
is redirected to address I<real-address> puts two consecutive C<Received:>
lines in the mail the first showing the I<real-address> address and the second
showing the original envelope address. Example:

	Received: from ... for person@real.com; ...
	Received: from ... for alias@virtual.org; ...

Note: When using B<majordomo> you B<must> use this option, since the internal
C<...-outgoing> never show up in one of the usual headers. They are used as
envelope addresses only.

=cut

my $realAddr = "";
my $realHost = "";

=item B<-v>

=item B<--verbose>

Operate verbose.

=cut

my $verb = 0;

=item B<-H>

=item B<--help>

Generate the man page for this program on standard output.

=cut

my $help = 0;

=back

=cut

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

require 5.005;

# Switch warning on
$^W = 1;

use strict;
use diagnostics;

use Getopt::Long qw( GetOptions );
use Carp qw( carp croak confess );

use FindBin;

{
  local %ENV = ( POSIXLY_CORRECT => 1 );
  Getopt::Long::config("default", "bundling");
}

use Mail::Internet;
use Mail::Address;

use File::Basename;

###############################################################################
###############################################################################
# Constants

# Header fields to search for virtual addresses
my @RedistTags = qw( Redist-To Redist-Cc );
my @NormTags = qw( To Cc );
my $RcvdTag = "Received";

# REs a RFC 822 mail address must match (plus underscore)
my $ReAddrChs = '[-a-zA-Z0-9._]+';
my $SAddrSep = '@';
my $ReAddr = $ReAddrChs . "\Q$SAddrSep" . $ReAddrChs;

# RE a include replacement in an `aliases' file must match; `$1' is the file to
# include
my $ReIncAli1 = '^:include:(/.*)$'; # '

# RE a command alias in an `aliases' file must match; `$1' is the command to
# execute
my $ReCmdAli1 = '^\|(.*)$'; # '

# RE a file alias in an `aliases' file must match
my $ReAppAli = '^/.*$'; # '

# Special header used to identify possible loops
my $MyHdrTag = "X-Valiases";

###############################################################################
###############################################################################
# Variables

###############################################################################
###############################################################################
# Unspecialized functions

# Outputs the given strings `@lns' as error message. Returns 0.
sub errO(@) {
  my( @lns ) = @_;

  my $lns;
  foreach $lns ( @lns ) {
    my $ln;
    foreach $ln ( split(/\n/, $lns) )
      { print(STDERR "$FindBin::Script: $ln\n"); }
  }
  return 0;
}

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

# Outputs the given strings `@lns' as verbose text. Returns 0.
sub vrbO(@) {
  my( @lns ) = @_;

  if($verb) {
    my $ln;
    foreach $ln ( @lns )
      { errO("## $ln"); }
  }
  return 0;
}

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

# Outputs error messages `@msg' and exits with code `$code'.
sub errEx($@) {
  my( $code, @msgs ) = @_;

  errO(@msgs);
  exit($code);
}

##############################################################################
##############################################################################
# Specialized functions

# Does log output of string `$s'.
sub logO($ ) {
  my( $s ) = @_;

  print(LOG $s)
      if $logF;
}

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

# Returns all the receiving addresses in `Mail::Header' object `$hdr' as a list
# of `Mail::Address' objects.
sub hdr2Addrs($ ) {
  my( $hdr ) = @_;

  my $i;

  # Collect lines of addresses
  my @addrLns;
  unless($ignRedist) {
    foreach $i ( @RedistTags )
      { push(@addrLns, $hdr->get($i)); }
  }
  unless(@addrLns) {
    foreach $i ( @NormTags )
      { push(@addrLns, $hdr->get($i)); }
  }

  # Collect addresses from the lines
  my @r;
  foreach $i ( @addrLns )
    { push(@r, Mail::Address->parse($i)); }

  # Consider received lines if wanted
  if($realAddr) {
    my @rcvds = $hdr->get($RcvdTag);
    my $fnd = 0;
    my $rcvd;
    foreach $rcvd ( @rcvds ) {
      # Look for a mail address
      if($rcvd =~ /$ReAddr/) {
	my $addr = $&;
	if("\L$addr" eq "\L$realAddr")
	  { $fnd = 1; }
	elsif($fnd) {
	  push(@r, Mail::Address->parse($addr));
	  last;
	}
      }
    }
  }

  return @r;
}

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

# Looks for virtual addresses `@$allVirts' among `Mail::Address' objects
# `@addrs' in domain `$dom' and returns the lower-cased local part of them as
# an array. Duplicates are removed.
sub addrs2Virts($$@) {
  my( $dom, $allVirts, @addrs ) = @_;

  my @r;
  my $addr;
  foreach $addr ( @addrs ) {
    next
	unless ($addr->host() || $realHost) eq $dom;

    my $user = $addr->user();
    $user = "\L$user";
    next
	unless grep{ $user eq $_ }(@$allVirts);
    next
	if grep{ $user eq $_ }(@r);
    vrbO("Found virtual address `" . $addr->address() . "'");
    push(@r, $user);
  }
  return @r;
}

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

# Parses a line of aliases `$ln' and returns them as an array.
sub getAliLn($ ) {
  my( $ln ) = @_;

  my @r;
  while($ln) {
    $ln =~ s/^[\s,]+//;
    if($ln =~ s/^\"([^\"]*)\"// || $ln =~ s/^([^\s,]+)//) {
      push(@r, $1)
	  if $1;
    }
    else {
      errEx(3, "Internal error")
	  if $ln;
    }
  }
  return @r;
}

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

# Opens, reads and parses alias file `$f' for a domain. Returns hash mapping
# the aliased names to an array containing there replacement.
sub getAliF($ ) {
  my( $f ) = @_;

  errEx(2, "Can't open alias file `$f'")
      unless open(ALI, $f);

  my %r;
  my $ali = "";
  my $ln;
  while(defined($ln = <ALI>)) {
    chomp($ln);
    # Comment and empty lines
    unless($ln =~ /^\s*($|\#)/) {
      # Addresses always start at the beginning of the line
      if($ln =~ /^($ReAddrChs):/) {
	$ali = $1;
	$ln = $';
	$r{$ali} = [ ];
      }
      elsif($ln !~ /^\s+/)
	{ errEx(2, "Invalid alias file `$f': Invalid alias definition `$ln'"); }
      else {
	errEx(2, "Invalid alias file `$f': Continuation line `$ln' continues nothing")
	    unless $ali;
      }
      push(@{$r{$ali}}, getAliLn($ln));
    }
  }
  close(ALI);
  return %r;
}

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

# Reads and parses include file `$f' containing lines with alias definitions.
# Returns array.
sub getIncF($ ) {
  my( $f ) = @_;

  unless(open(INC, $f)) {
    errO("Can't open include file `$f'");
    return ( );
  }

  my @r;
  my $ln;
  while(defined($ln = <INC>)) {
    chomp($ln);
    $ln =~ s/^\s*//;
    next
	if $ln =~ /^($|\#)/;

    push(@r, ( split(/ /, $ln, 2) )[0]);
  }

  return @r;
}

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

# Expands aliases in `%alis'. First all references to files are expanded. Then
# local addresses are replaced by their alias expansion or by their full
# address in domain `$dom'. Finally all aliases are lower-cased. Returns a hash
# with full expansion.
sub expAlis($%) {
  my( $dom, %alis ) = @_;

  my %r;
  my $expPoss;
  my %ali2Seen;

  # Expand als references to include files
  for(%ali2Seen = ( ), $expPoss = 1; $expPoss; %alis = %r) {
    $expPoss = 0;
    %r = ( );

    my( $ali, $orgs );
    while(( $ali, $orgs ) = each(%alis)) {
      my @exps;
      my $org;
      foreach $org ( @$orgs ) {
	if($org =~ $ReIncAli1) {
	  my $fNm = $1;
	  if(defined($ali2Seen{$ali})) {
	    errEx(2, "Circular inclusion of file `$fNm' in alias `$ali' for domain `$dom'")
	       if grep{ $fNm eq $_ }(@{$ali2Seen{$ali}});
	  }
	  else
	    { $ali2Seen{$ali} = [ ]; }
	  push(@{$ali2Seen{$ali}}, $fNm);
	  $expPoss = 1;
	  push(@exps, getIncF($fNm));
	}
	else
	  { push(@exps, $org); }
      }
      $r{$ali} = [ @exps ];
    }
  }

  # Expand local aliases
  for(%ali2Seen = ( ), $expPoss = 1; $expPoss; %alis = %r) {
    $expPoss = 0;
    %r = ( );

    my( $ali, $orgs );
    while(( $ali, $orgs ) = each(%alis)) {
      my @exps;
      my $org;
      foreach $org ( @$orgs ) {
	if($org =~ /^$ReAddrChs$/) {
	  my $loc = $&;
	  if(defined($alis{$loc})) {
	    if(defined($ali2Seen{$ali})) {
	      errEx(2, "Circular reference in alias `$ali' for domain `$dom'")
		  if grep{ $loc eq $_ }(@{$ali2Seen{$ali}});
	    }
	    else
	      { $ali2Seen{$ali} = [ ]; }
	    push(@{$ali2Seen{$ali}}, $loc);
	    $expPoss = 1;
	    push(@exps, @{$alis{$loc}});
	  }
	  else
	    { push(@exps, $loc . $SAddrSep . $dom); }
	}
	else
	  { push(@exps, $org); }
      }
      $r{$ali} = [ @exps ];
    }
  }

  # Lowercase aliases
  %r = ( );
  my( $ali, $orgs );
  while(( $ali, $orgs ) = each(%alis)) {
    $ali = "\L$ali";
    $r{$ali} = [ ]
	unless defined($r{$ali});
    push(@{$r{$ali}}, @$orgs);
  }

  return %r;
}

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

# Checks and logs aliases `%alis' for domain `$dom'.
sub chkAlis($%) {
  my( $dom, %alis ) = @_;

  logO("# $dom\n");

  my $ali;
  foreach $ali ( sort(keys(%alis)) ) {
    logO("$ali:");

    my $sep = " ";
    my $exp;
    foreach $exp ( @{$alis{$ali}} ) {
      if($exp =~ /$ReCmdAli1/) {
	my $cmd = $1;
	$cmd = ( split(" ", $cmd, 2) )[0];
	errEx(2, "Command `$cmd' is not executable")
	    unless -x($cmd);
      }
      elsif($exp =~ /$ReAppAli/) {
	my $f = $&;
	errEx(2, "Directory for `$f' doesn't exist")
	    unless -d(dirname($f));
	if(-f($f)) {
	  errEx(2, "File `$f' is not writable")
	      unless -w($f);
	}
	else {
	  errEx(2, "Directory of `$f' is not writable")
	      unless -w(dirname($f));
	}
      }
      logO($sep . ($exp =~ /\s/ ? "\"$exp\"" : $exp));
      $sep = ", ";
    }
    logO("\n");
  }
}

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

# Modifies Mail::Header `$hdr' of outgoing mail. `@virts' are all the virtual
# addresses on which behalf the mail should be sent. It should be non-empty.
sub modHdr($@) {
  my( $hdr, @virts ) = @_;

  if(defined($prgLns)) {
    my $cnt = $hdr->count($RcvdTag);
    $prgLns = $cnt
	if $prgLns <= 0 || $cnt < $prgLns;
    $hdr->delete($RcvdTag, 0)
	while $prgLns--;
  }
  $hdr->add($MyHdrTag, join(" ", @virts), 0);
}

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

# Sends `Mail::Internet' object `$mail' to aliases `@alis'. Processes special
# aliases such as files and commands and sends to other addresses using
# `sendmail'.
#
# `sendmail -O AliasFile=...' doesn't work since `sendmail' refuses to run as
# root when given an alias file which however is needed to process mail :-(
# :-( .
sub sendAlis($@) {
  my( $mail, @alis ) = @_;

  my @addrs;
  my $ali;
  foreach $ali ( @alis ) {
    if($ali =~ /$ReCmdAli1/) {
      my $cmd = $1;
      vrbO("Piping mail to command `$cmd'");

# `majordomo' malfunctions using this approach :-( :-( . Problem seems to be,
# that the body of a mail is not properly recognized.
#
#       errEx(2, "Can't open command `$cmd'")
# 	  unless open(CMD, "|$cmd");
#       $mail->print(\*CMD);
#       errEx(2, "Can't close command `$cmd'")
# 	  unless close(CMD);

      my $tmpF = "/tmp/valiases.$$";
      errEx(2, "Can't open temporary file for `$cmd'")
	  unless open(TMP, ">$tmpF");
      $mail->print(\*TMP);
      close(TMP);
      system("< $tmpF $cmd");
      unlink($tmpF);

      logO(" \"$ali\"");
    }
    elsif($ali =~ /$ReAppAli/) {
      my $appF = $&;
      vrbO("Appending mail to file `$appF'");
      errEx(2, "Can't open file `$appF' to append mail to")
	  unless open(APP, ">>$appF");
      $mail->print(\*APP);
      close(APP);
      logO(" $ali");
    }
    else
      { push(@addrs, $ali); }
  }

  if(@addrs) {
    my $cmd = "/usr/lib/sendmail @addrs";
    vrbO("Sending mail using `$cmd'");
    errEx(2, "Can't open `sendmail'")
	unless open(SEND, "|$cmd");
    $mail->print(\*SEND);
    errEx(2, "Can't close `sendmail'")
	unless close(SEND);
    logO(" @addrs");
  }
}

##############################################################################
# Handle arguments

my $usageS = "Usage: $FindBin::Script [-H] [-v] [-l <log>] [-i] [-c] [-r <real-address>] [-d <alias-dir>] [-p <lines>] [<domain> [<aliases>]]...";

# Options and usage
errEx(1, $usageS)
    unless GetOptions("v|verbose" => \$verb,
		      "i|ignore-redist" => \$ignRedist,
		      "l|log=s" => \$logF,
		      "c|check" => \$chkAlis,
		      "d|alias-dir=s" => \$alisD,
		      "r|received=s" => \$realAddr,
		      "p|purge=i" => \$prgLns,
		      "H|help" => \$help);

exec("perldoc $FindBin::Bin/$FindBin::Script")
    if $help;

errEx(1, "$usageS")
    if @ARGV % 2 && !$alisD;

if($logF) {
  errEx(2, "Can't open log file `$logF'")
      unless open(LOG, ">>$logF");
}

$realHost = ( Mail::Address->parse($realAddr) )[0]->host()
    if $realAddr;

##############################################################################
# Now work

# Get domains and expand the aliases
my %dom2Alis;
while(@ARGV) {
  my $dom = shift(@ARGV);
  my $aliF = $alisD ? "$alisD/$dom" : shift(@ARGV);
  errEx(2, "Invalid domain `$dom'")
      unless $dom =~ /^$ReAddrChs$/;
  $dom2Alis{$dom} = { expAlis($dom, getAliF($aliF)) };
}

# Check aliases if wanted
my( $dom, $alis );
if($chkAlis) {
  chkAlis($dom, %$alis)
      while ( $dom, $alis ) = each(%dom2Alis);
  exit(0);
}

# Get the mail and look for addresses to ignore
my $mail = Mail::Internet->new(\*STDIN, Modify => 0);
my @alrdys = map{ split() }($mail->head()->get($MyHdrTag));
vrbO("Ignoring virtual addresses `@alrdys'")
    if @alrdys;

# Look for valid virtual addresses in the mail
my %dom2Virts;
my @allVirts;
while(( $dom, $alis ) = each(%dom2Alis)) {
  my @virts;
  my $virt;
  foreach $virt
      ( addrs2Virts($dom, [ keys(%$alis) ], hdr2Addrs($mail->head())) ) {
    push(@virts, $virt)
	unless grep{ "$virt$SAddrSep$dom" eq $_ }(@alrdys);
  }
  next
      unless @virts;

  push(@allVirts, map{ "$_$SAddrSep$dom" }(@virts));
  $dom2Virts{$dom} = [ @virts ];
}

# Modify header and send mail to virtual addresses if necessary
if(@allVirts) {
  modHdr($mail->head(), @allVirts);
  while(( $dom, $alis ) = each(%dom2Alis)) {
    next
	unless defined($dom2Virts{$dom});

    my @alis = map{ @{$alis->{$_}} }(@{$dom2Virts{$dom}});
    logO("[" . localtime() . "] $dom");
    sendAlis($mail, @alis);
    logO("\n");
  }
}
else
  { vrbO("No virtual address found"); }

=head1 RETURN VALUE

The program exits without an error if there is at least one occurence of a
virtual mail address. If there is no virtual mail address at all, the program
exits with an error status 1.

This can be used to control the operation of B<slocal> in a F<.maildelivery>
file. An entry of

	*	-	|	A	"<path>/valiases <domain> <aliases>"

may be the right thing to do.

If B<-c> is given the program exits without an error only if all alias files
are correct.

=cut

close(LOG)
    if $logF;
exit(!@allVirts);

=head1 USING A LOCAL MAJORDOMO

B<valiases> has been mainly created to support a local B<majordomo>
installation. The following notes on installing such a B<majordomo> might be
helpful.

The most important thing is that such a B<majordomo> does not need any special
permissions such as root permissions or being in group B<daemon>. Here are some
hints following the description of a clean install in the F<INSTALL> file of
B<majordomo> Version 1.94.5.

=over 4

=item 1)

You need no special group or user id to run B<majordomo> under. Your personal
user and group are just fine.

=item 2)

The installation directory may be anywhere but something like
F<$HOME/lib/majordomo> seems to be a good choice.

=item 3)

You do not need to give permissions to anyone else but yourself. C<600> and
C<700> are fine.

Comment the POSIX section and uncomment the non-POSIX section. We do not need
root set-uid.

=item 4)

Set C<$whereami> to the I<domain> you want your local B<majordomo> to appear to
be in.

Remove the C<-f\$sender> flag from C<$mailer> and C<$bounce_mailer>. Normally
this sets the envelope C<From> address but may not be used if B<sendmail> is
not run by a trusted user. This is the only disadvantage of such a installation
as far as a I can see.

=item 8)

When adding aliases for a new list to I<aliases> note that no program may use
local addresses. In particular for aliases using the B<resend> command, they
have to give the fully qualified address as the final argument (e.g.
C<new-outgoing@>I<domain>).

=back

When setting up B<valiases> you B<must> use B<-r> because only this way the
original envelope addresses are available.

=head1 BUGS

If B<valiases> receives a single mail via two or more distinct addresses
independently from each other, B<valiases> has no way to know that this is
actually the same mail. Thus it handles each mail independently which may
result in duplication of the mail. A solution to this problem would involve a
local history on sent mails.

=head1 PREREQUISITES

Because this is a Perl program, Perl (>= V5.005) must be installed.

This program needs the great C<MailTools> package installed. Try

	http://search.cpan.org/search?dist=MailTools

=head1 SEE ALSO

L<slocal>, L<majordomo>, L<resend>, L<sendmail>, L<aliases>

=head1 AUTHOR

Stefan Merten <smerten@oekonux.de>

=head1 LICENSE

This program is licensed under the terms of the GPL. See

	http://www.gnu.org/licenses/gpl.txt

=head1 AVAILABILTY

See

	http://www.merten-home.de/FreeSoftware/valiases/

=cut