140 lines
3.8 KiB
Perl
Executable File
140 lines
3.8 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
#
|
|
# Copyright (C) 2001-2019 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 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 ;
|
|
}
|
|
|