#!/usr/bin/env perl
#
# Copyright (C) 2001-2018 Graeme Walker <graeme_walker@users.sourceforge.net>
#
# 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/>.
# ===
#
# emailrelay-bcc-check.pl
#
# An example emailrelay filter script that rejects messages
# that have a non-empty "Bcc:" recipient list unless the "Bcc:"
# recipient list contains a single addressee that matches
# envelope recipient.
#
# Bcc handling is generally only a concern for e-mail user agent
# programs and not relays and proxies. User agents should
# normally submit a message separately for each Bcc recipient
# with either no "Bcc:" field or with the "Bcc:" field
# containing that one recipient (see RFC-5322).
#
# Note that correct parsing of content files is beyond the
# scope of a simple example script like this, and incorrect
# Bcc handling can have a serious privacy implications.
#

use strict ;
use FileHandle ;
$SIG{__DIE__} = sub { (my $e = join(" ",@_)) =~ s/\n/ /g ; print "<<error: $e>>\n" ; exit 99 } ;

my $content = @ARGV[0] or die "usage error\n" ;
my $verbose = 1 ;

# read the bcc list from the content file
my %c = headers( $content ) ;
my @bcc = split( /,/ , $c{Bcc} ) ; # todo -- allow for commas in quoted strings
map { print "BCC=[$_]\n" } @bcc if $verbose ;

# allow if there is no bcc list or it's empty
exit 0 if scalar(@bcc) == 0 ;
my $bcc = $bcc[0] =~ s/^\s*"?//r =~ s/"?\s*$//r ;
exit 0 if( $bcc =~ m/^\s*$/ ) ;

# read the recipient list from the envelope file
my @rcp = read_fields( find_envelope($content) , qr/^X-MailRelay-To-Remote:\s*(.*)/ ) ;
map { print "RECIPIENT=[$_]\n" } @rcp if $verbose ;

# allow if there are no (remote) recipients at all
exit 0 if scalar(@rcp) == 0 ;
my $rcp = $rcp[0] ;

# allow if one recipient matching one bcc
exit 0 if( scalar(@rcp) == 1 && scalar(@bcc) == 1 && $bcc =~ m/\Q$rcp\E/ ) ;

# deny otherwise
print "<<bcc error>>\n" ;
exit 1 ;

sub headers
{
	my ( $file ) = @_ ;
	my $fh = open_file( $file ) ;
	my %h = read_headers( $fh ) ;
	$fh->close() or die ;
	return %h ;
}

sub read_headers
{
	my ( $fh ) = @_ ;
	my %h = () ;
	my $k ;
	while(<$fh>)
	{
		chomp( my $line = $_ ) ;
		$line =~ s/\r$// ;
		last if ( $line eq "" ) ;
		my ( $a , $b , $c , $d ) = ( $line =~ m/^(\S*):\s*(.*)|^(\s)(.*)/ ) ;
		if( $a ) { $h{$a} = $b ; $k = $a }
		if( $k && $d ) { $h{$k} .= "$c$d" }
	}
	return %h ;
}

sub open_file
{
	my ( $file ) = @_ ;
	my $fh = new FileHandle( $file , "r" ) or die "cannot open [$file]: $!\n" ;
	return $fh ;
}

sub envelope
{
	my ( $content , $ext ) = @_ ;
	$ext = "" if !defined($ext) ;
	$content =~ m/\.content$/ or die "invalid content filename [$content]\n" ;
	( my $envelope = $content ) =~ s/\.content$/.envelope/ ;
	$envelope .= $ext ;
	return $envelope ;
}

sub find_envelope
{
	my ( $content ) = @_ ;
	map { return $_ if -f $_ } map { envelope($content,$_) } ( "" , ".new" , ".busy" ) ;
	die "no envelope for [$content]\n" ;
}

sub read_fields
{
	my ( $file , $re ) = @_ ;
	return map { s/$re/$1/ ; $_ } grep { m/$re/ } read_all( $file ) ;
}

sub read_all
{
	my ( $file ) = @_ ;
	my $fh = open_file( $file ) ;
	my @lines = () ;
	while(<$fh>)
	{
		chomp( my $line = $_ ) ;
		$line =~ s/\r$// ;
		push @lines , $line ;
	}
	$fh->close() or die ;
	return @lines ;
}

