#!/usr/bin/env perl
#
# Copyright (C) 2001-2021 Graeme Walker <graeme_walker@users.sourceforge.net>
# 
# Copying and distribution of this file, with or without modification,
# are permitted in any medium without royalty provided the copyright
# notice and this notice are preserved.  This file is offered as-is,
# without any warranty.
# ===
#
# emailrelay-bcc-check.pl
#
# An example E-MailRelay "--filter" script that rejects e-mail messages that
# have a non-empty "Bcc:" recipient list unless the "Bcc:" recipient list
# contains a single addressee that matches the envelope recipient. This has
# the effect of checking that a submitting user agent is behaving correctly
# as per RFC-5322 3.6.3.
#
# 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.
#
# 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" } # folding
	}
	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 ;
}