emailrelay-check-address-domains.pl

#!/usr/bin/env perl
#
# SPDX-FileCopyrightText: 2026 Graeme Walker <graeme_walker@users.sourceforge.net>
# SPDX-License-Identifier: FSFAP
#
# Copyright (c) 2026 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-check-address-domains.pl
#
# An example E-MailRelay filter script that checks the
# envelope-from address and all the envelope-to recipient
# addresses against a hard-coded allow-list.
#

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

# list of allowed domains...
my @allow = qw(
    books.example.com
    xn--bcher-kva.example.de
) ;

# read the envelope file
my $envelope = $ARGV[1] or die "usage error\n" ;
my $fh = new IO::File( $envelope ) or die "cannot open envelope file: $!\n" ;
my $txt ;
{
    local $/ = undef ;
    $txt = <$fh> ;
}

my @denied = () ;

# check the envelope 'from' address
{
    my ( $address_from ) = ( $txt =~ m/X-MailRelay-From:\s*(\S*)/m ) ;
    push @denied , $address_from if !allow_address($address_from) ;
}

# check the envelope 'to' addresses
{
    my @address_to = () ;
    map {
            my $line = $_ ;
            my ( $a ) = ( $line =~ m/^X-MailRelay-To-[^:]*:\s*(\S*)/ ) ;
            push @denied , $a if ( defined($a) && !allow_address($a) ) ;
    } split( /\r\n/ , $txt ) ;
}

# return the result
if( scalar(@denied) )
{
    print "<<invalid domain>>\n" ;
    print "<<" , join(",",@denied) , ">>\n" ;
    exit( 1 ) ;
}
else
{
    exit( 0 ) ;
}

#

sub allow_address
{
    my ( $address ) = @_ ;
    my ( $domain ) = ( $address =~ m/@(.*)/ ) ;
    $domain ||= "" ;
    return grep { m/^\Q$domain\E$/i } @allow ;
}