develooper Front page | perl.cvs.qpsmtpd | Postings from March 2007

[svn:qpsmtpd] r721 - contrib/vetinari

From:
vetinari
Date:
March 3, 2007 04:06
Subject:
[svn:qpsmtpd] r721 - contrib/vetinari
Message ID:
20070303120644.EF6C8CBA2A@x12.develooper.com
Author: vetinari
Date: Sat Mar  3 04:06:42 2007
New Revision: 721

Added:
   contrib/vetinari/realname

Log:
added realname plugin

Added: contrib/vetinari/realname
==============================================================================
--- (empty file)
+++ contrib/vetinari/realname	Sat Mar  3 04:06:42 2007
@@ -0,0 +1,374 @@
+=head1 NAME
+
+realname - filter To: headers' real name 
+
+=head1 DESCRIPTION
+
+The B<realname> plugin filters the messages by comparing the given C<To:> 
+header with a list of allowed C<real names> for the address from the C<To:>
+header.
+
+By default it just logs what is found. You have to configure each possible
+DENY on it's own on the command line of the plugin.
+
+Only addresses listed in the I<realname> config file will be checked.
+
+=head1 SYNOPSIS
+
+realname [arg [CONSTANT[=message]]] [arg [CONSTANT[=message]]]
+
+=head1 CONFIG
+
+The I<realname> config file contains the real name and a list of mail adresses
+this user receives mail at. The real name may be given between C</>s or inside
+double quotes ('"'). If surrounded by C</> it's treated as a regular 
+expression, else the name will be split by white space and some possible 
+names will be built as regex, prefixed by the C<title> argument:
+
+A name like "John Doe" will be tried as 'John Doe', 'J. Doe', 'Mr. John Doe'
+and 'Mr. J. Doe'.
+
+Several different real names for one address may be given, see the "John Doe" 
+and "My Alter Ego" lines below, mixing of strings and regexes for one address
+is of course possible (on two different lines ;-)).
+
+ "John Doe"  j.doe@example.com,john.doe@example.com,john@example.com
+ /John \"JD\" Doe/ j.doe@example.com,john.doe@example.com,john@example.com
+ "My Alter Ego" j.doe@example.com
+ "Jane Doe" jane.doe@example.com,jane@example.com
+ /Some (name|other) w\. Reg(e|E)x/ user@example.com
+
+=cut
+
+use Qpsmtpd::Constants;
+use Qpsmtpd::DSN;
+use Mail::Address;
+use MIME::QuotedPrint;
+use MIME::Base64;
+use Text::Iconv;
+
+=head1 ARGUMENTS
+
+All arguments except C<title> and C<charset> have the form 
+
+ argument CONSTANT
+
+or 
+
+ argument CONSTANT=MESSAGE
+
+The MESSAGE must not contain white space, all C<_> will be converted to a 
+space. The CONSTANT must be a valid constant from I<Qpsmtpd::Constants>. The
+default value for CONSTANT is C<DECLINED>.
+
+Some replacements are done before returning the message:
+
+ $ADDR - address from the C<To:> header
+ $USER - local part of $ADDR
+ $HOST - host part of $ADDR
+ $NAME - decoded real name of the C<To:> header
+ $ENCODED - the raw real name of the C<To:> header
+
+The checks are done on the order given below.
+
+=head2 title
+
+The C<title> argument must be a regular expression of possible titles, default
+is C<(Herrn?|Frau|M(r|s)\\.?)>.
+
+=head2 charset
+
+The real name from the C<To:> header is decoded (from quoted printable or
+base64) and converted to this charset. I suggest to keep the default of 
+C<UTF-8> and edit your config file in UTF-8.
+
+=head2 no_config
+
+C<To:> header's address not found in config file, default message:
+C<No config for $ADDR (To: '$NAME')>.
+
+=head2 accepted
+
+Triggers if the address from the header matched the real name, default message 
+is C<accepted real name '$NAME' for $ADDR>.
+
+=head2 address
+
+Triggers if the real name is the same as the address (case insensitive). Default
+message is C<address $ADDR eq real name '$NAME'>.
+
+=head2 missing_space 
+
+Triggers if the local part contains a dot (C<.>) and the real name is equal to 
+the local part (case insensitive). Default message: C<real name '$NAME' has 
+missing spaces>.
+
+=head2 extra_space 
+
+Triggers if the local part contains a dot (C<.>) and the real name is equal to 
+the local part (case insensitive) with spaces around the dot. Default message: 
+C<real name '$NAME' has extra spaces>, example: C<J . Doe E<lt>j.doe@example.comE<gt>>.
+
+=head2 missing_dot
+
+If the local part of the address contains a dot and the real name is equal to
+the local part with the dot replaced by a space, default message is
+C<real name '$NAME' is missing a dot>.
+
+=head2 user
+
+Triggers if the lower cased local part is equal to the lower cased real name, 
+default message is C<local part '$USER' eq real name '$NAME'>.
+
+=head2 random
+
+After none of the above checks triggered, the real name is assumed to be a 
+random generated name. The default message for this is
+C<real name '$NAME' is random for $ADDR>.
+
+=head1 NOTES
+
+Create your realname config and run this plugin without any arguments. Then
+browse the log file(s) and just enable those arguments, where you're sure 
+no valid mails are dropped. I had some C<false positives> after a few weeks
+(while running this plugin in log only mode :)), those were tweaked and now
+I haven't seen one for quite some time.
+
+=cut
+
+my %config = (
+    address       => [ DECLINED, "address \$ADDR eq real name '\$NAME'"      ],
+    extra_space   => [ DECLINED, "real name '\$NAME' has extra spaces"       ],
+    user          => [ DECLINED, "local part '\$USER' eq real name '\$NAME'" ],
+    missing_dot   => [ DECLINED, "real name '\$NAME' is missing a dot"       ],
+    missing_space => [ DECLINED, "real name '\$NAME' has missing spaces"     ],
+    random        => [ DECLINED, "real name '\$NAME' is random for \$ADDR (\$ENCODED)"   ],
+    # 
+    no_config     => [ DECLINED, "No config for \$ADDR (To: '\$NAME')"       ],
+    accepted      => [ DECLINED, "accepted real name '\$NAME' for \$ADDR"    ],
+    # 
+    charset       => "UTF-8",
+    # charset       => "ISO-8859-15",
+    title         => "(Herrn?|Frau|M(r|s)\\.?)",
+    );
+
+sub register {
+    my ($self, $qp, %args) = @_;
+    # $config{charset} = $args{charset} || "UTF-8";
+    $config{charset} = $args{charset} || $config{charset};
+    delete $args{charset};
+
+    $config{title} = $args{title} || $config{title};
+    delete $args{title};
+
+    foreach my $key (keys %args) {
+        if (exists $config{$key}) {
+            my ($const, $value) = split /=/, $args{$key}, 2;
+
+            $value = $config{$key}->[1]
+              unless defined $value;
+            $value =~ s/_/ /g;
+
+            $const = Qpsmtpd::Constants::return_code($const) || DECLINED;
+            $config{$key} = [ $const, $value ];
+        }
+    }
+}
+
+sub hook_data_post {
+    my ($self, $transaction) = @_;
+    $self->{_real} = {};
+    my $test;
+    my $plugin = $self->plugin_name;
+    my $to     = $transaction->header->get("To:")
+      or return(DECLINED, "No To: header");
+
+    my @addr = Mail::Address->parse($to)
+      or return(DECLINED, "Failed to parse To: header");
+    
+    my $user = lc $addr[0]->user;
+    return(DECLINED, "user part not defined") 
+      unless defined $user;
+    $self->{_real}->{user} = $user;
+    
+    my $host = $addr[0]->host;
+    return(DECLINED, "host part not defined") 
+      unless defined $host;
+    $self->{_real}->{host} = $host;
+
+    my $name = $addr[0]->name;
+    return(DECLINED, "No real name to extract") 
+      unless (defined $name and $name);
+    $self->{_real}->{encode} = $name;
+
+    ### err .. Something like 
+    ###  =?ISO-8859-15?Q?"J=F6rn?= Karl =?UTF-8?Q?K=C3=B6nig"?=
+    ### (=F6 and =C3=B6 is the same after converting from iso-8859-15 / utf-8 
+    ###  ... )
+    ### is possible ... (yes, I've seen such a crap ...)
+    $name =~ s/^\s*//;
+    $name =~ s/\s*$//s;
+    my $result = "";
+    $name =~ s/\s*[\r\n]+\s*//msg;
+    while ($name =~ s/^([^?]*)?=\?([^?]+)\?(\w)\?([^\?]+?)=?\?=//i) { 
+        my ($pre,$charset,$enc,$quoted) = ($1,uc($2),uc($3),$4);
+        $pre     = ""      unless defined $pre; 
+        $charset = 'UTF-7' if $charset eq 'UNICODE-1-1-UTF-7'; # exchange...
+        my $iconv   = Text::Iconv->new($charset, $config{charset});
+        return(DECLINED, "Found unknown charset '$charset' in "
+                       . "encoded To: header")
+          unless $iconv;
+        if ($enc eq 'Q') {
+            $quoted = decode_qp($quoted) || $quoted;
+        }
+        elsif ($enc eq 'B') {
+            $quoted = decode_base64($quoted) || $quoted;
+        }
+        else {
+            return(DECLINED, "Found unknown encoding '$enc' in "
+                            ."encoded To: header");
+        }
+        $quoted    =  $iconv->convert($quoted) || $quoted;
+        $quoted    =~ s/_+/ /g; # yes ...
+        $result   .=  $pre.$quoted;
+    }
+    $name = $result.$name;
+    $name =~ s/\\(.)/$1/g;
+    $name =~ s/^\s*(["'])(.+)\1\s*$/$2/;
+    $name =~ s/^\s*//;
+    $name =~ s/\s*$//;
+    $name =~ s/"//g;
+
+    $self->{_real}->{name} = $name;
+
+    my @real = $self->real_names(lc($user.'@'.$host));
+    return($self->ret_msg(@{$config{no_config}}))
+      unless (@real);
+
+    # $self->qp->log(LOGDEBUG, "$plugin: REAL='".join("', '", @real)."'");
+    foreach my $regex (@real) {
+        # $self->qp->log(LOGDEBUG, "$plugin: CHECK: $name =~ '$regex'");
+        return($self->ret_msg(@{$config{accepted}}))
+          if ($name =~ /$regex/i);
+    }
+
+    # j.doe@example.com => "J.Doe@Example.Com" <j.doe@example.com>
+    return($self->ret_msg(@{$config{address}}))
+      if (lc($name) eq lc($user.'@'.$host));
+    
+    if ($user =~ /\./) { 
+        # j.doe@example.com => J.Doe <j.doe@example.com>
+        return($self->ret_msg(@{$config{missing_space}}))
+          if $user eq lc($name);
+
+        # j.doe@example.com => J . Doe <j.doe@example.com>
+        ($test = $user) =~ s/\./ . /;
+        $test =~ s/\s+/ /g;
+        return($self->ret_msg(@{$config{extra_space}}))
+          if lc($test) eq lc($name);
+
+        # j.doe@example.com => J Doe <j.doe@example.com>
+        ($test = $user) =~ s/\./ /;
+        return($self->ret_msg(@{$config{missing_dot}}))
+          if lc($test) eq lc($name);
+    }
+
+    # jd@example.com => jd <jd@example.com>
+    return($self->ret_msg(@{$config{user}}))
+      if $user eq lc($name);
+
+    return($self->ret_msg(@{$config{random}}));
+}
+
+sub ret_msg {
+    my $self = shift;
+    my $code = shift;
+    my $msg  = shift;
+    my $addr = $self->{_real}->{user}.'@'.$self->{_real}->{host};
+    $msg =~ s/\$ADDR/<$addr>/g;
+    $msg =~ s/\$USER/$self->{_real}->{user}/g;
+    $msg =~ s/\$HOST/$self->{_real}->{host}/g;
+    $msg =~ s/\$NAME/$self->{_real}->{name}/g;
+    $msg =~ s/\$ENCODED/$self->{_real}->{encode}/g;
+    ## this will look a bit odd if $code is DECLINED, it will 
+    ## write a (#4.x.y) status in log...
+    return Qpsmtpd::DSN->media_unsupported($code, $msg);
+    ## hmm... it's a bit of an integrity failure ;->
+    # return Qpsmtpd::DSN->sec_msg_integrity_failure($code, $msg);
+}
+
+sub real_names {
+    my $self  = shift;
+    my $user  = shift;
+    my @out   = ();
+    my $i     = 0;
+    my @names = $self->qp->config("realname");
+    foreach my $line (@names) {
+        ++$i;
+        if ($line =~ /^\s*"([^"]+)"\s+(\S+)\s*$/) {
+            my ($real, $list) = ($1, $2);
+         NAME:
+            foreach my $name (split /,/, $list) {
+                if ($name eq $user) {
+                    push @out, $self->mk_regex($real);
+                    last NAME;
+                }
+            }
+        }
+        elsif ($line =~ m#^\s*/([^/]+)/\s+(\S+)\s*$#) {
+            my ($real, $list) = ($1, $2);
+         REGEX:
+            foreach my $name (split /,/, $list) {
+                if ($name eq $user) {
+                    push @out, qr#$real#;
+                    last REGEX;
+                }
+            }
+        }
+        else {
+            $self->qp->log(LOGDEBUG, "unparseable line $i in realname config");
+            next;
+        }
+    }
+    return @out;
+}
+
+sub mk_regex {
+    my $self  = shift;
+    my $name  = shift;
+    my @out   = ();
+    $name     =~ s/^\s*//;
+    $name     =~ s/\s*$//;
+
+    my $title = $config{title};
+    my @parts = split /\s+/, $name;
+    my $full  = join("\\s+", map { quotemeta($_) } @parts);
+    # $self->qp->log(LOGDEBUG, "real_name: FULL='$full'");
+    push @out, qr#^\s*($title\s+)?$full\s*$#;
+    # $self->qp->log(LOGDEBUG, "real_name: adding ".$out[-1]);
+
+    my $last  = quotemeta(pop @parts);
+    push @out, qr#^\s*($title\s+)?$last\s*$#;
+    # $self->qp->log(LOGDEBUG, "real_name: adding ".$out[-1]);
+
+    while (@parts) {
+        my $n = pop @parts;
+        my $qn = quotemeta $n;
+        push @out, qr#^\s*$last,\s*$qn\s*$#;
+        my $c;
+        ($c = $n) =~ s/^(.).*$/$1/;
+        my $f = join("\\s+", @parts);
+        if ($f) {
+            push @out, qr#^\s*($title\s+)?$f\s+$c\.\s+$last\s*$#;
+            push @out, qr#^\s*$last,\s+$f\s+$c\.\s*$#;
+            # $self->qp->log(LOGDEBUG, "real_name: adding ".$out[-1]);
+        }
+        else {
+            push @out, qr#^\s*($title\s+)?$c\.\s+$last\s*$#;
+            push @out, qr#^\s*$last,\s+$c\.\s*%#;
+            # $self->qp->log(LOGDEBUG, "real_name: adding ".$out[-1]);
+        }
+    }
+    return @out;
+}
+# vim: ts=4 sw=4 expandtab syn=perl



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About