#!/usr/bin/perl -w
# Change the path in the above line to where perl lives on your system 
# The command: which perl     should reveal this path on most systems.
#
# shared-mailbox.pl
# Author: Richard Kay, <rich AT copsewood DOT net> 
# Last Changed: 25 April 2001
# 
# License: This program is distributed under the terms of the GNU
#          Public License version 2 or later. 
# 
# Warranty: None whatsoever. If it breaks you have to pick up all the
#           pieces yourself.
#
# Status:  Alpha release, probably missing important features
#          but works for the program author to a useful extent.
#
# Credits:
# Mark-Jason Dominus - contributed some neat Perl code used for
# parsing mail headers see:
# http://www.linuxplanet.com/linuxplanet/tutorials/1096/3/ 
#
# Larry Wall, Tom Christiansen & Randal Schwartz - use of srand see
# Programming Perl, publisher: O'Reilly & Associates.

#
# Version Notes: 
# 0.1 first public release 12/03/2001
# 0.1.1 variable initialisation bug fixed 10/4/2001
# 0.1.2 incorrect search string for loop detect key fixed 25/4/01
#
# Documentation:
# See README file accompanying this program and read the source code 

# INSTALLATION CONFIGURABLE VARIABLES 

# VARIABLES YOU WILL NEED TO CHANGE 

# shared mailbox address to which mail being processed was sent. E.G if  
# messages sent to anyone@some-company.co.uk were caught in
# a POP3 mailbox with a username of everyone then set
# $shared_address='everyone@some-company.co.uk';

$shared_address='shared-box@your.domain.whatever.that.is'; 

# mail address to inform if unsafe attempt to forward mail to a program or list
# or suspect a mail loop. This address MUST NOT USE AUTOFORWARDING
# OR AUTORESPONSE OR YOU RISK CREATING AN INFINITE MAIL LOOP ! 
# You can use a local mail address like 'fred' or a remote one like 
# 'fred@flint.stones.org' or whatever here. 
$security_admin='rich';

# if $bounce = 0; (see $bounce below) then
# person to send message to if all attempts to find a match fail
# You can also use local or remote style mail addresses here.
$last_resort='rich'; 

# VARIABLES YOU MIGHT NEED TO CHANGE 

# location of mail aliases file, normally /etc/aliases
$aliasfile="/etc/aliases";

# location of local user login data, normally /etc/passwd
# You may need something different if you're using NIS
$pwfile="/etc/passwd";

# minimum UID in field 3 of $pwfile for which a match will
# be attempted, default 100. If you want everything in $pwfile 
# matched then set this value to 0. On some systems postmaster
# has an account rather than an alias. Postmasters should receive 
# external mail and might have a UID lower than 100. Setting this value to 
# the postmaster UID if your system has one should work OK, otherwise
# set it to the lowest UID which should receive external mail.
$min_safe_uid=100;

# location of MTA program
$sendmail = "/usr/sbin/sendmail";

# Max number of Received headers greater than or equal to which a mail 
# loop is considered to be active. Default value is 40.
$max_received = 40;

# In debug mode ( $debug = 1; ) output is sent to stdout rather than
# the usual mail recipients. Used for test only. Normally $debug = 0; 
$debug = 0; 

# In backup mode ( $backup = 1; ) an extra copy of the output is
# saved in a file with a sequence number as filename.
# If you are more concerned about privacy or the disk filling up 
# than the possibility of an irrecoverable lost or misdirected message 
# set $backup = 0; 
$backup = 1;

# unsafe aliases are considered to be programs you pipe mail into 
# and :include: lists.
# I have enough POP3 boxes for my Majordomo program and list addresses.
# If you havn't, or really need to reduce the overall polling
# work on your remote server, change the next line from 1 to 0 only 
# if you know what you're doing or are willing to risk it, 
# as I guess it might potentially open up various kinds of security hole.
$safe_aliases_only=1; # 1 for yes, 0 for no

# name of file containing loop detection key
$ldk_file = ".loop-detect-key";

# name of file containing names of other mailboxes handled seperately
# remember to update this file if you change the names of your external
# mailboxes.
$other_boxes="other_mailboxes"; 

# Name of backup index lock file. We don't want more than one process
# to try writing the backup index file simultaneously, and mail can 
# arrive in multiples, due to the way POP3 polling works.
$bi_lockfile=".shared_mailbox_bi_lockfile";

# Whether to bounce mail to unidentifiable recipient addresses in
# the manner sendmail would. (should this be Return-path: then
# From: then Reply-to: address  ??? . What do the RFC standards say ? 
# This feature is not yet implemented. 
# default 0 or no bounce. If you want to bounce such mail set $bounce = 1;
# and implement this feature.)
# $bounce = 0; 

# END OF INSTALLATION CONFIGURABLE VARIABLES. If you need to change 
# anything below this point and consider your fix likely to be 
# useful to other users of shared-mailbox then please mail changes
# to rich AT copsewood DOT net

# Is this the first time program has run ? If no read loop
# detection key file, if yes generate this key as a value
# unique for this program installation and file it.

$addrpart = $shared_address; # shared address should be unique
$addrpart =~ s/\W/_/g; # change punctuation to _underscore chars 
$ldk=$addrpart."_"; # should be unique now anyway, but make really sure
                # by appending a long randomish number to loop detect key
if( -s $ldk_file && -f $ldk_file){ # file exists, so read it
  open(LDK,$ldk_file) or die "cant open4read .loop_detect_key file";
  $ldk=<LDK>;
  close(LDK);
} else { # file doesn't exist, so create it
  # seed randomish number generator
  srand(time() ^ ($$ + ($$ << 15)) ); # not crypto secure but good enough 
  # append a large random integer to further customise loop detect key 
  $ldk.=1000000+(int (rand 1000000000)); 
  open(LDK,">$ldk_file") or die "cant open4write .loop_detect_key file";
  print LDK $ldk;
  close(LDK);
}
$ldk_header="X-Shared_Mailbox_Loop_Detection_Key: ".$ldk;
if($debug){ print "ldk_header:\n$ldk_header\n"; }

# extract usable Perl regexps from shared address to match address parts

$shared_address =~ /\@/; # match address on address @ delimiter to get:
$shared_mbox = $`; # the bit before the @ 
$mail_domain = $'; # and the bit after the @ 
$mail_domain =~ s/\./\\\./; # precede dots (.) in domain with backslash

# split message received through standard input into $header and $body 
# The first local $/ variable to the { } block changes line delimiter to 
# the empty line which exists between mail header and mail body

{
  local $/ = ""; 
  $header = <STDIN>; 
  undef $/; 
  $body = <STDIN>; 
}

# split headers into array so that all headers are
# concatenated with subsequent lines starting with whitespace
# to join up multi-line headers 

@headers = split /\n(?!\s)/, $header; 

# insert loop detection header for outgoing message only
while($header =~ /\s$/ ){ # chop any whitespace off end of header
  chop $header;
}
$header.="\n";
$header.=$ldk_header;

# reconstruct outgoing message as an array 
$msg[0]=$header;
$msg[1]="\n\n";
$msg[2]=$body;

# do loop detection on incoming headers

$received=0; $smldk=0;
foreach (@headers){
  if(/^Received\:/i){
    $received++; # count received headers to detect mail loop
  } elsif (/^$ldk_header/){
    $smldk++; # This message has looped through here before !!
  }
}

# prepare to save local backup copy under an incremented index number

# Attempt to fix bug here when 2+ emails arrive at once - by making this
# code multi-processing aware using a lock file and a sleep loop so only 
# 1 process can read/write access the backup index file at once. Also 
# has a cleanup check for apparantly dead processes with undeleted lockfiles.

if($backup){
  $bi_checks=0;
  while( -e $bi_lockfile){
    # some other shared_mailbox process has a lock on the backup index file
    if($bi_checks>=30){
      # something odd happened here - took 1 minute to index a backup ? 
      # Another process may have created lockfile but crashed or hung 
      # before it could remove this lockfile. Let's count number of 
      # times we have seen the same PID (process ID), and kill
      # any process if it is seen 10 times. 
      $process_id=`cat $bi_lockfile`;
      if($debug){ print "process_id: $process_id\n";}
      if($processtable{$process_id}){
        $processtable{$process_id}++; # count how many times this process seen
      } else {
        $processtable{$process_id}=1;
      }
      if($processtable{$process_id} >= 10){ 
	      # same process locked file for 20 seconds, so
	kill 9,$process_id; # kill it as it definitely looks crashed or hung 
        unlink ($bi_lockfile); # remove lockfile
	if($debug){ print "killed $process_id and removed lockfile\n";}
      }
    }
    sleep 2; # back off while another process updates index
    $bi_checks++;
  }
  # create index lockfile and write process ID (PID) to it
  open(LOCK,">$bi_lockfile");
  print LOCK $$; # $$ is the PID of our process 
  close(LOCK);
  open(INDEX,"index");
  $index=<INDEX>;
  $index++;
  close(INDEX);
  open(INDEX,">index");
  print INDEX $index;
  close(INDEX); 
  unlink ($bi_lockfile);
  open(BACKUP,">$index");
}

# First extract headers likely to contain addressee.
$prefixes_found=0;
foreach (@headers){
  if(/^Received\:|^To\:|^Cc\:|^Bcc\:/i){
    @used_headers=(@used_headers,$_);
  }
}

# input list of mailboxes for domain handled seperately, addresses 
# of which will be excluded from matching.

$num_otherbs=0;
if(-f $other_boxes && -s $other_boxes){
  open(OTHERS,$other_boxes);
  while (<OTHERS>){
    unless(/^#/){ # ignore comment lines
      s/\s+//g; # strip spaces and newlines
      tr/A-Z/a-z/; # convert CAPS to lowercase 
      @otherbs=(@otherbs,$_); # add to array
      $num_otherbs++;
    }
  }
  close(OTHERS);
}

# add shared_mbox prefix as one of the addresses which if contained
# in an incoming message will not be forwarded to a local user or alias.
$otherbs[$num_otherbs]=$shared_mbox;

# next analyse headers to find addressee

foreach (@used_headers){
  # parse header on characters thought likely to delimit mail addresses	
  @words=split(/(\s|\;|\:|\,|\>|\<|\'|\"|\[|\]|\(|\)|\{|\}|\|)+/);
  foreach $word (@words){
    if($word =~ /\w\@$mail_domain$/i){
      $word =~ /\@/; # match word on address @ delimiter to
      $prefix=$`;    # get address prefix
      $included=1; # assume prefix included unless it matches an excluded one
      foreach $excluded_prefix (@otherbs){
        if($excluded_prefix eq $prefix){
          $included=0;
        }
      }
      if($included){ 
        @prefixes=(@prefixes,$prefix); 
	$prefixes_found++;
      }
    } 
  }
}

# list local users with safe UIDs.
open(PWFILE,$pwfile) or die "cant open $pwfile";
while($_ = <PWFILE>){
  @pwrec=split /:/;
  if($pwrec[2] >= $min_safe_uid && $pwrec[0] =~ /^[a-z][a-z0-9_]*$/){
    # looks like we have a sensible userid and safe UID so add user to list
    @local_users=(@local_users,$pwrec[0]);
  }
}
close(PWFILE);

# find mail aliases matching destination address prefixes
open(ALIASES,$aliasfile);
@aliases=<ALIASES>;
close(ALIASES);
$number_matched=0;
$matches="";
$found_unsafe=0;
$matched_this_prefix=0;
MATCH: foreach $prefix (@prefixes){
  $prefix =~ tr/A-Z/a-z/; # lowercase prefix
  if($debug){ print "prefix: $prefix\n";} 
  # see if prefix matches one of our local aliases
  $matched_this_prefix=0;
  foreach $_ (@aliases){
    unless(/^\s*$|^\#/){ #ignore blank lines or comment alias lines
      ($alias,$remainder)=split(/:/,$_,2);
      $alias =~ tr/A-Z/a-z/; # lowercase alias 
      if($alias eq $prefix){
	$matched_this_prefix=1;
        if($safe_aliases_only && $remainder =~ /\:include|\|/i){ 
	  # safe aliases don't involve forwarding to a list or program
	  $found_unsafe=1;
	  @msg=("\nshared-mailbox.pl: attempt to use unsafe mail alias\n",@msg);
	  @msg=("\nCwood_index: $index prefix: $prefix\n",@msg);
          last MATCH; # quit matching now 
        }
        $number_matched++; # matched an alias 
        $matches=$matches." ".$alias; 
      }
    }
  }
  unless($matched_this_prefix){ 
    # only search @local_users if there was no matching alias 
    foreach $local_user (@local_users){
      if( $prefix eq $local_user){
        $number_matched++; # matched a local user
        $matches=$matches." ".$local_user; 
	$matched_this_prefix=1;
      }
    } 
  }
}

# save backup copy to opened file. Check elsif($smldk > 1) section below before 
# removing backup facility from this program if it is thought stable enough 
# such that privacy matters more than message security.
if($backup){
  print BACKUP @msg;
  print BACKUP "\nshared-mailbox.pl: backup index number: $index matches: $matches\n";
  close(BACKUP);
}

if($found_unsafe){
  $recipients=$security_admin;
  @msg=("\nshared-mailbox.pl: UNSAFE MAIL DETECTED index: $index\n",@msg);
} elsif($smldk == 1){ # probably a mail loop
  $recipients=$security_admin;
  @msg=("\nshared-mailbox.pl: MAIL LOOP DETECTED index: $index\n",@msg);
} elsif($smldk > 1){ # Mail has looped through here twice !!!! 
  # This should never, ever happen. Only reason I can think of is that mail is 
  # looping through the security_admin.  See the warning above that 
  # the security_admin address shouldn't be auto-forwarding mail. If this
  # happens then the local mail environment is now so completely untrusted for 
  # the purpose of forwarding this message to anyone or for outputting errors 
  # of any kind which might end up in the mail system that just quitting 
  # quietly and doing nothing further seems to be the only sane option.
  if($debug){ # ability to test this error trap is useful in debug mode.
    system("echo MAIL LOOP CONFIG ERROR index: $index >> LOOP_CRASH");
  }
  exit 0;
} elsif($received >= $max_received){ # probably a mail loop 
  $recipients=$security_admin;
  @msg=("\nshared-mailbox.pl: MAIL LOOP DETECTED index: $index\n",@msg);
} elsif($prefixes_found > 0 && $number_matched > 0){
  if($prefixes_found == $number_matched){ # all prefixes were matched 
    $recipients=$matches;
  } else {
    # some mail prefixes received for which no alias matched 
    $recipients=$matches." $last_resort";
    @msg=(@msg,"\nshared-mailbox.pl: some prefix/es unmatched\nindex: $index");
  }
} else { # no match found
  $recipients=$last_resort;
  @msg=(@msg,"\nshared-mailbox.pl: no mail prefix matched\nindex: $index");
}

unless($debug){
  open(RECIPIENT,"| $sendmail $recipients");
  print RECIPIENT @msg;
  close(RECIPIENT);
} else {
  print "message:\n@msg\n";
  print "matches: $matches recipients: $recipients\n";
}