PerlMail/Config.pm

   1 #! /usr/bin/perl
   2 #
   3 #       $Id$
   4 # Copyright (C) 2002-2003 Jan Kratochvil <project-PerlMail@jankratochvil.net>
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program; if not, write to the Free Software
  18 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  19
  20
  21 package PerlMail::Config;
  22 use vars qw($VERSION);
  23 $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; };
  24 use strict;
  25 use warnings;
  26
  27 require Exporter;
  28 use vars qw(@ISA @EXPORT);
  29 @ISA=qw(Exporter);
  30 @EXPORT=qw(
  31                 $HOME
  32                 $Mail @ValidUsers $IdleMax $MaxBodySMS @SMSwebRcpt $SMSwebRcpt_username
  33                 $Lock_pathname $PeerAddr $Socket_timeout $DB_table $DBI_database $DBI_user $DBI_pwd
  34                 $clamscan_waitpid_timeout
  35                 $sendmail_orig @addr_addon &FromAddress @h_rcpt @h_from
  36                 %audit_profile @sms_squeezes @alternates_host @dnsbl_whitelist
  37
  38                 $Audit $is_pgp $opt_F $procmailFROM_MAILER $store_ignore $store_ignorenewmail
  39                 $store_profile
  40                 );
  41
  42 require Mail::Alias;
  43
  44
  45 BEGIN {
  46         for (qw(headerhas store headeris did dnsbl store_muttrc_alternates Received_for parts_linear mime_type
  47                         body_first mimehead spamassassin clamscan header_remap)) {
  48                 eval 'sub '.$_.' { return ::'.$_.'(@_); }';
  49                 }
  50         }
  51
  52
  53 # perlmail-accept & perlmail-sendmail
  54
  55 # Various configuration files location is derived from it:
  56 our $HOME="/home/USERNAME";
  57
  58
  59 # perlmail-accept
  60
  61 # Mail folder:
  62 our $Mail="$HOME/Mail";
  63 # Users respected for the 'idle' state (see $IdleMax):
  64 our @ValidUsers=qw(root USERNAME _local);
  65 # Maximum number of local console idle seconds while still considered as 'active user':
  66 our $IdleMax=10;
  67 # Maxium number of bytes to pass to Lingua::EN::Squeeze (performance optimization):
  68 our $MaxBodySMS=0x1000;
  69 # Telephone number to send SMSes by WWW::SMS to:
  70 our @SMSwebRcpt=qw(123 456 789123);
  71 # Some WWW::SMS modules require username:
  72 our $SMSwebRcpt_username="SMSUSERNAME";
  73 our $clamscan_waitpid_timeout=3;
  74
  75
  76 # perlmail-submit
  77
  78 # Global system lock for exclusive $DB_table access:
  79 our $Lock_pathname="/tmp/PerlMail.lock";
  80 # 'workstation' hostname and port. Hostname may be dyndns:
  81 our $PeerAddr="workstation.hostname.tld.:852";
  82 #our $PeerAddr="127.0.0.1:2852";
  83 # 15sec is NOT enough as the remote peer must complete mail store:
  84 our $Socket_timeout=7600;
  85 # MySQL table name:
  86 our $DB_table="PerlMail_folder";
  87 # MySQL database name:
  88 our $DBI_database="USERNAME";
  89 # MySQL user name:
  90 our $DBI_user="USERNAME";
  91 # MySQL user password:
  92 our $DBI_pwd=$ENV{"HOME"}."/priv/mysql.".$DBI_user.".pwd";
  93
  94
  95 # perlmail-sendmail
  96
  97 # Pathname of the original sendmail(8) binary:
  98 our $sendmail_orig=(-x ($_="/usr/sbin/sendmail-orig") ? $_ : "/usr/sbin/sendmail");
  99 # List of addresses to locally Bcc all mails to:
 100 # Mail-Alias-1.12 defaults to "/etc/mail/aliases" which does not exist on RedHat sendmail-8.12.5-7
 101 # Mail-Alias-1.12 will clutter $_ !
 102 our @addr_addon=(Mail::Alias->new("/etc/aliases")->exists("sentout") ? ("sentout") : ());
 103
 104 our $opt_F;     # imported
 105 our $is_pgp;    # imported
 106 # Generate new From address for the target $rcpt of type Mail::Address.
 107 # $iserror is true for "MAIL FROM" RFC821 address, false for "From:" RFC822 address.
 108 # Returns: Mail::Address instance.
 109 sub FromAddress
 110 {
 111 my($rcpt,$iserror)=@_;
 112
 113         my $phrase=(defined $opt_F ? $opt_F : "FULL NAME");
 114         return Mail::Address->new($phrase,'USER@DOMAIN.TLD');
 115 }
 116
 117 # RedHat sendmail-8.9.3-20/src/conf.c/HdrInfo[]/\Q/* destination fields */\E
 118 # FIXME: Recognize "Resent-$_" headers for -t but when we are in 'resent' mode?
 119 our @h_rcpt=(   # case in-sensitive!
 120                 "To",
 121                 "Cc",
 122                 "Bcc",
 123                 "Apparently-To",
 124                 );
 125 # ordering matters; first header found is substituted
 126 # last header is subsituted if no one is found
 127 our @h_from=(
 128                 "Resent-From",
 129                 "From",
 130                 );
 131
 132
 133 # My-Audit
 134
 135 # Setup profile names.
 136 # First element of /^=/ form copies it referenced profile to be extended.
 137 # 'did'    =>did() subroutine will return true for it.
 138 # 'syslog' =>Use syslog(3).
 139 # 'bell'   =>Bell sound.
 140 # 'sms=\d+'=>Send SMS by WWW::SMS with specified maximum # of parts
 141 our %audit_profile=(
 142                 "btw"   =>[],
 143                 "silent"=>["=btw"   ,"did"],
 144                 "log"   =>["=silent","syslog"],
 145                 "bell"  =>["=log"   ,"bell"],
 146                 "sms"   =>["=bell"  ,"sms=1"],
 147                 "crit"  =>["=sms"   ,"sms=3"],
 148                 );
 149 # Try the squeezing methods in this order:
 150 our @sms_squeezes=(
 151                 { "SqueezeControl"=>"noconv"                         },
 152                 { "SqueezeControl"=>"conv"  ,"SQZ_OPTIMIZE_LEVEL"=>0 },
 153                 { "SqueezeControl"=>"conv"  ,"SQZ_OPTIMIZE_LEVEL"=>1 },
 154                 { "SqueezeControl"=>"med"   ,"SQZ_OPTIMIZE_LEVEL"=>0 },
 155                 { "SqueezeControl"=>"med"   ,"SQZ_OPTIMIZE_LEVEL"=>1 },
 156                 { "SqueezeControl"=>"max"   ,"SQZ_OPTIMIZE_LEVEL"=>0 },
 157                 { "SqueezeControl"=>"max"   ,"SQZ_OPTIMIZE_LEVEL"=>1 },
 158                 );
 159 # Hostnames where we had alternate e-mail addresses:
 160 our @alternates_host=(
 161                 );
 162 # Override DNS blacklists:
 163 our @dnsbl_whitelist=(
 164                 "64.49.222.22",         # mail.pm.org: rackspace.com.spam-support.blackholes.five-ten-sg.com.
 165                 "208.147.243.5",        # gambit.liquidcomm.net: cw.net.spam-support.blackholes.five-ten-sg.com.
 166                 "205.139.198.11",       # eniac.disaster.com: cw.net.spam-support.blackholes.five-ten-sg.com.
 167                 "127.0.0.2",                    # 2.0.0.127.relays.ordb.org.
 168                 "65.113.40.131",        # bozo.vmware.com: qwest.net.spam-support.blackholes.five-ten-sg.com.
 169                 "66.218.85.33",         # mta2.wss.scd.yahoo.com: yahoo.com.spam.blackholes.five-ten-sg.com.
 170                 );
 171
 172 our $Audit;     # imported
 173 our $procmailFROM_MAILER;       # imported
 174 our $store_ignorenewmail;       # imported
 175 our $store_profile;     # imported
 176 our $store_ignore;      # imported
 177 sub audit
 178 {
 179         $store_profile=undef();
 180
 181         # never spawn new mail if FROM_MAILER
 182         # $isFROM_MAILER postponed after maillists as they may look as FROM_MAILER
 183         #use re 'debug';
 184         my $isFROM_MAILER=$Audit->header()=~/$procmailFROM_MAILER/mio;
 185         $store_ignorenewmail=(0
 186                         || $isFROM_MAILER
 187                         || headerhas "From",'<Regexp:^owner->'
 188                         );
 189
 190         # spam honeypots
 191         return if did sub {
 192                 # Do not local $store_file as it is our-imported
 193                 $store_profile="log";
 194                 local $_;
 195                 store "=spam".";virus=$_"            if $_=clamscan();
 196                 store "=spam".";spamassassin".($_ eq 1 ? "" : "=$_") if $_=spamassassin();
 197                 store "=spam".";$_"                  if $_=dnsbl '.relays.ordb.org.' ,1;        # all hosts
 198                 store "=spam".";$_"                  if $_=dnsbl '.blackholes.mail-abuse.org.' ,1;      # all hosts
 199                 # we don't check all hosts as they can be "dialup" category, FIXME: check for it
 200 #               store "=spam".";$_"                  if $_=dnsbl '.blackholes.five-ten-sg.com.',0; # just first
 201                 # I don't send viruses but viruses propagate mails of mine
 202                 store "=spam".";ravmd"               if headeris "X-Mailer",'ravmd/8.3.2';
 203                 };
 204         $store_profile=undef();
 205
 206         # spam detection
 207         return if did sub {
 208                 # Do not local $store_file as it is our-imported
 209                 $store_profile="silent";
 210                 local $_;
 211                 store "=spam".($_ eq 1 ? "" : ";$_")      if $_=spamassassin();
 212                 };
 213         $store_profile=undef();
 214         return if did sub {
 215                 # Do not local $store_file as it is our-imported
 216                 $store_profile="silent";
 217                 local $_;
 218                 store "=spam"                      .";$_","log" if $_=dnsbl '.relays.ordb.org.' ,1;     # all hosts
 219                 store "=spam"                      .";$_","log" if $_=dnsbl '.blackholes.mail-abuse.org.' ,1;   # all hosts
 220                 # we don't check all hosts as they can be "dialup" category, FIXME: check for it
 221                 store "=spam"                      .";$_","log" if $_=dnsbl '.blackholes.five-ten-sg.com.',0; # just first
 222                 # I don't send viruses but viruses propagate mails of mine
 223                 store "=spam"                                   if headeris "X-Mailer",'ravmd/8.3.2';
 224                 };
 225         $store_profile=undef();
 226
 227         # ppl-wished foreign remapping, Reply-To is left untouched!
 228         # FIXME: modifications are now being dropped by &write_message!
 229         header_remap("From",{
 230                         'RECEIVED@ADDRESS.TLD'=>'MAP_TO@ADDRESS.TLD',
 231                         });
 232
 233         # My obsolete e-mail addresses
 234         store_muttrc_alternates "=redirect-","btw";
 235
 236         # nasty public lists with $store_ignore
 237         {
 238                 # Do not local $store_file as it is our-imported
 239                 $store_profile="log";
 240                 local $store_ignore;
 241                 $store_ignore="smsmail"    if 1==$Audit->body() && length(join "",$Audit->body())<180;  # SMS mail
 242                 $store_ignore="list-moron" if grep { headeris "From",$_; } qw(
 243                                 <SOMEONE@SOMEWHERE.COM>
 244                                 );
 245
 246                 store "=LOCALNAME"         if headeris  "Sender"   ,'<OWNER-XYZZY@DOMAIN.TLD>';
 247                 }
 248         $store_profile=undef();
 249
 250         # lists
 251         store "=LIST","log"          if headeris "List-Id"  ,'<SOME.ID.OF.THE.LIST>';
 252
 253         store "=errm","bell"         if $isFROM_MAILER && !did();
 254
 255         if (!did) {
 256                 store "==","sms";
 257                 spamassassin "$HOME/bin/sa-learn --ham";
 258                 }
 259 }
 260
 261 sub audit_sms_address
 262 {
 263 my($obj)=@_;
 264
 265         my $address=$obj->address();
 266         if (my $alternates=muttrc_get("alternates")) {
 267                 return "I" if $address=~/$alternates/si;
 268                 }
 269         my %aliases=muttrc_aliases();
 270         if (my $alias=$aliases{lc $address}) {
 271                 local $_=$alias;
 272                 s/\b(Bus)siness$/$1/i;
 273                 s/\.ident$//i;
 274                 return $_;
 275                 }
 276         local $_=$address;
 277         s/\.cz$//i;
 278         return $_;
 279 }
 280
 281 # $args{"from"}
 282 # $args{"subject"}
 283 # $args{"body"}
 284 sub audit_sms
 285 {
 286 my(%args)=@_;
 287
 288         my $from=(@{$args{"from"}} ? join(",",map({ audit_sms_address($_); } @{$args{"from"}})) : "?");
 289         local $_;
 290
 291         $_=$args{"subject"};
 292         # headers
 293         s/(?:Re|Aw|Odp|Fw|Fwd|OT)(?:\[\d+\])?://ig;
 294         # former subject
 295         s/\bbylo:.*$//i;
 296         s/\[\s*WAS:.*\]\s*$//i;
 297         # trim
 298         s/^\s*//s;
 299         s/\s*$//s;
 300         my $subject=$_;
 301
 302         $_=$args{"body"};
 303         # max. 9 lines of .sig
 304         s/\n-- (?:\n[^\n]*){0,9}$//gs;
 305         # "Original Message"/"Puvodni zprava" etc. up to empty line
 306         # "- - - Original message: - - -" is by "Lotus Notes Release 5.0.5  September 22, 2000"
 307         s/(^|\n)[\s^\n]*(?:-----[\w\s]*-----|- - - Original message: - - -)[\s^\n]*(?:\n[^\n]+)*\n{2,}(?:\s*[^>\s].*$)?/\n/gs;
 308         # Remove "..." lines (is it used by anyone except me?)
 309         s/^\Q...\E$/*/gm;
 310         # quoting "> "
 311         s/^(?:\s*[[:upper:]]{0,3}>)+.*$/*/gm;
 312         s/(?:^|\n)(?:\*\n+)+/\n*\n/gs;
 313         # attributions
 314         s/^.*\b(?:wrote|writes|napsal jste):\s*$//gm;
 315         my $body=$_;
 316
 317         return [$from,"($subject)$body"];
 318 }
 319
 320 1;