X-Git-Url: http://git.jankratochvil.net/?p=PerlMail.git;a=blobdiff_plain;f=My-Audit.pm;h=15416e6d0cb6e3d1633ef043c0f64944796c2572;hp=c81515e92889e40cbb16d2a21e13aec5be6bbc36;hb=595dde9002608bf18a84b22dafd5fe779c500421;hpb=ec7d34da4cccb27afe64d488bb0ee67a9d64a957

diff --git a/My-Audit.pm b/My-Audit.pm
index c81515e..15416e6 100644
--- a/My-Audit.pm
+++ b/My-Audit.pm
@@ -4,7 +4,7 @@ sub audit_init
 {
 	%audit_profile=(
 			"btw"   =>[],
-			"silent"=>["=btw"   ,"did","syslog"],
+			"silent"=>["=btw"   ,"did"],
 			"log"   =>["=silent","syslog"],
 			"bell"  =>["=log"   ,"bell"],
 			"sms"   =>["=bell"  ,"sms=1"],
@@ -19,6 +19,11 @@ sub audit_init
 			{ "SqueezeControl"=>"max"   ,"SQZ_OPTIMIZE_LEVEL"=>0 },
 			{ "SqueezeControl"=>"max"   ,"SQZ_OPTIMIZE_LEVEL"=>1 },
 			);
+	@alternates_host=(
+			"jabberwock.ucw.cz",	# short@ucw.cz
+			"atrey.karlin.mff.cuni.cz",	# short@atrey.karlin.mff.cuni.cz
+			"k332.feld.cvut.cz",	# short@k332.feld.cvut.cz
+			);
 }
 
 sub audit
@@ -38,10 +43,12 @@ sub audit
 	return if did sub {
 		local $store_profile="silent";
 		local $_;
-		store "=spam-rbl"                  .";$_"  if $_=$Audit->rblcheck();
-		store "=spam-razor".($_ eq 1 ? "" : ";$_") if $_=razor2();
+		store "=spam-abuse"                .";$_","log" if $_=dnsbl '.blackholes.mail-abuse.org.' ,1;	# all hosts
+		# we don't check all hosts as they can be "dialup" category, FIXME: check for it
+		store "=spam-five"                 .";$_","log" if $_=dnsbl '.blackholes.five-ten-sg.com.',0; # just first
+		store "=spam-razor".($_ eq 1 ? "" : ";$_")      if $_=razor2();
 		# I don't send viruses but viruses propagate mails of mine
-		store "=spam-av"                           if headeris "X-Mailer",'ravmd/8.3.2';
+		store "=spam-av"                                if headeris "X-Mailer",'ravmd/8.3.2';
 		};
 
 	# spam honeypots
@@ -93,6 +100,7 @@ sub audit
 				<satko@quanto.nr.sanet.sk>
 				<vithous@attorney.cz> <viroman@attorney.cz>
 				<konf@klain.cz>
+				<stein@tiscali.cz>
 				);
 
 		store "=gsm"               if headeris  "Sender"   ,'<owner-gsm@sh.cvut.cz>';
@@ -109,20 +117,22 @@ sub audit
 	store "=gtkd","log"          if headeris "List-Id"  ,'<gtk-devel-list.gnome.org>';
 	store "=mffstatnice","bell"  if headeris "List-Post",'<statnice@atrey.karlin.mff.cuni.cz>';
 	store "=hw","log"            if headeris "List-Post",'<hw-news@list.gin.cz>';
-	store "=gnokii","bell"       if headeris "List-Id"  ,'<gnokii-users.mail.freesoftware.fsf.org>';
+	store "=gnokii","log"        if headeris "List-Id"  ,'<gnokii-users.mail.freesoftware.fsf.org>';
 	store "=winelic","log"       if headeris "List-Id"  ,'<wine-license.winehq.com>';
 	store "=wined","log"         if headeris "List-Id"  ,'<wine-devel.winehq.com>';
-	store "=winepat","log"       if headeris "List-Id"  ,'<wine-patches.winehq.com>';
+	store "=winepat","silent"    if headeris "List-Id"  ,'<wine-patches.winehq.com>';
 	store "=winecvs","silent"    if headeris "List-Id"  ,'<wine-cvs.winehq.com>';
+	store "=wineann","log"       if headeris "List-Id"  ,'<wine-announce.winehq.com>';
 	store "=ros","log"           if headeris "List-Post",'<ros-general@reactos.com>';
-	store "=roskernel","bell"    if headeris "List-Post",'<ros-kernel@reactos.com>';
+	store "=roskernel","log"     if headeris "List-Post",'<ros-kernel@reactos.com>';
 	store "=roscvs","silent"     if headeris "List-Post",'<ros-cvs@reactos.com>';
 	store "=fsd","log"           if headeris "X-Mailing-List",'<linux-fsdevel@vger.kernel.org>';
 	store "=surprise","sms"      if headeris "List-Post",'<surprise@atrey.karlin.mff.cuni.cz>';
 	store "=surprisesuse","sms"  if headeris "Sender"   ,'<owner-surprise@suse.cz>';
 	store "=tacacs","log"        if headeris "Sender"   ,'<tacplus-l@disaster.com>';
+	store "=tacacsd","log"       if headerhas \&Received_for,'devel@tacplus.org';	# TODO: fix when real list
 	store "=pm","sms"            if headeris "Sender"   ,'<owner-prague-pm@pm.org>';
-	store "=radary","sms"        if headeris "Reply-To" ,'<pha@radary.cz>';
+	store "=radary","log"        if headeris "Reply-To" ,'<pha@radary.cz>';
 	store "=dnet","log"          if headeris "Sender"   ,'<@lists.distributed.net>';
 	store "=linux-input","log"   if headeris "List-Post",'<linux-input@atrey.karlin.mff.cuni.cz>';
 	store "=strom","bell"        if headeris "List-Post",'<vodni-strom@atrey.karlin.mff.cuni.cz>';
@@ -139,36 +149,67 @@ sub audit
 	store "=energie","bell"      if headeris "From"     ,qr/^EnergieWeb/;
 
 	# Petr Koutecky does not mark his Stuff
-	store "=koutecky","bell"     if headeris "From"     ,'<velkyhroch@seznam.cz>';
+	store "=koutecky","log"      if headeris "From"     ,'<velkyhroch@seznam.cz>';
 
 	store "=errm","bell"         if $isFROM_MAILER && !did();
 
 	store "==","sms"             if !did;
 }
 
+sub audit_sms_address
+{
+my($obj)=@_;
+
+	my $address=$obj->address();
+	if (my $alternates=muttrc_get("alternates")) {
+		return "I" if $address=~/$alternates/si;
+		}
+	my %aliases=muttrc_aliases();
+	if (my $alias=$aliases{lc $address}) {
+		local $_=$alias;
+		s/\.cz$//i;
+		return $_;
+		}
+	local $_=$address;
+	s/\b(Bus)siness$/$1/i;
+	s/\.ident$//i;
+	return $_;
+}
+
 sub audit_sms
 {
 my(%args)=@_;
 
-	my $from=(@{$args{"from"}} ? join(",",map({
-			s/\.cz$//i;
-			$_;
-			} @{$args{"from"}})) : "?");
-	local $_=$args{"body"};
-
+	my $from=(@{$args{"from"}} ? join(",",map({ audit_sms_address($_); } @{$args{"from"}})) : "?");
+	local $_;
+
+	$_=$args{"subject"};
+	# headers
+	s/(?:Re|Aw|Odp|Fw|Fwd|OT)(?:\[\d+\])?://ig;
+	# former subject
+	s/\bbylo:.*$//i;
+	s/\[\s*WAS:.*\]\s*$//i;
+	# trim
+	s/^\s*//s;
+	s/\s*$//s;
+	my $subject=$_;
+
+	$_=$args{"body"};
 	# max. 9 lines of .sig
 	s/\n-- (?:\n[^\n]*){0,9}$//gs;
 	# "Original Message"/"Puvodni zprava" etc. up to empty line
-	s/(^|\n)[\s^\n]*-----[\w\s]*-----[\s^\n]*(?:\n[^\n]+)*\n{2,}(?:\s*[^>\s].*$)?/\n/gs;
+	# "- - - Original message: - - -" is by "Lotus Notes Release 5.0.5  September 22, 2000"
+	s/(^|\n)[\s^\n]*(?:-----[\w\s]*-----|- - - Original message: - - -)[\s^\n]*(?:\n[^\n]+)*\n{2,}(?:\s*[^>\s].*$)?/\n/gs;
 	# Remove "..." lines (is it used by anyone except me?)
 	s/^\Q...\E$/*/gm;
 	# quoting "> "
-	s/^\s*[>][>\s]*.*$/*/gm;
+	s/^(?:\s*[[:upper:]]{0,3}>)+.*$/*/gm;
 	s/(?:^|\n)(?:\*\n+)+/\n*\n/gs;
 	# attributions
-	s/^On.*\b(?:wrote|writes):\s*$//gm;
+	s/^.*\b(?:wrote|writes|napsal jste):\s*$//gm;
+	my $body=$_;
 
-	return [$from,"(".$args{"subject"}.")".$_];
+	return [$from,"($subject)$body"];
 }
 
 1;