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 lmtp_deliver)) {
  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 $lmtp_admin="cyrus";
  74 our $lmtp_pwd;
  75 {
  76         local *F;
  77         open F,"$HOME/priv/lmtp.${lmtp_admin}.pwd" or die;
  78         $lmtp_pwd=<F>;
  79         chomp $lmtp_pwd;
  80         close F or die;
  81         }
  82 our $lmtp_user_from="USERNAME";
  83 our $lmtp_user_to="CYRUSUSERNAME";
  84 our $clamscan_waitpid_timeout=3;
  85
  86
  87 # perlmail-submit
  88
  89 # Global system lock for exclusive $DB_table access:
  90 our $Lock_pathname="/tmp/PerlMail.lock";
  91 # 'workstation' hostname and port. Hostname may be dyndns:
  92 our $PeerAddr="workstation.hostname.tld.:852";
  93 #our $PeerAddr="127.0.0.1:2852";
  94 # 15sec is NOT enough as the remote peer must complete mail store:
  95 our $Socket_timeout=7600;
  96 # MySQL table name:
  97 our $DB_table="PerlMail_folder";
  98 # MySQL database name:
  99 our $DBI_database="USERNAME";
 100 # MySQL user name:
 101 our $DBI_user="USERNAME";
 102 # MySQL user password:
 103 our $DBI_pwd=$ENV{"HOME"}."/priv/mysql.".$DBI_user.".pwd";
 104
 105
 106 # perlmail-sendmail
 107
 108 # Pathname of the original sendmail(8) binary:
 109 our $sendmail_orig=(-x ($_="/usr/sbin/sendmail-orig") ? $_ : "/usr/sbin/sendmail");
 110 # List of addresses to locally Bcc all mails to:
 111 # Mail-Alias-1.12 defaults to "/etc/mail/aliases" which does not exist on RedHat sendmail-8.12.5-7
 112 # Mail-Alias-1.12 will clutter $_ !
 113 our @addr_addon=(Mail::Alias->new("/etc/aliases")->exists("sentout") ? ("sentout") : ());
 114
 115 our $opt_F;     # imported
 116 our $is_pgp;    # imported
 117 # Generate new From address for the target $rcpt of type Mail::Address.
 118 # $iserror is true for "MAIL FROM" RFC821 address, false for "From:" RFC822 address.
 119 # Returns: Mail::Address instance.
 120 sub FromAddress
 121 {
 122 my($rcpt,$iserror)=@_;
 123
 124         my $phrase=(defined $opt_F ? $opt_F : "FULL NAME");
 125         return Mail::Address->new($phrase,'USER@DOMAIN.TLD');
 126 }
 127
 128 # RedHat sendmail-8.9.3-20/src/conf.c/HdrInfo[]/\Q/* destination fields */\E
 129 # FIXME: Recognize "Resent-$_" headers for -t but when we are in 'resent' mode?
 130 our @h_rcpt=(   # case in-sensitive!
 131                 "To",
 132                 "Cc",
 133                 "Bcc",
 134                 "Apparently-To",
 135                 );
 136 # ordering matters; first header found is substituted
 137 # last header is subsituted if no one is found
 138 our @h_from=(
 139                 "Resent-From",
 140                 "From",
 141                 );
 142
 143
 144 # My-Audit
 145
 146 # Setup profile names.
 147 # First element of /^=/ form copies it referenced profile to be extended.
 148 # 'did'    =>did() subroutine will return true for it.
 149 # 'syslog' =>Use syslog(3).
 150 # 'bell'   =>Bell sound.
 151 # 'sms=\d+'=>Send SMS by WWW::SMS with specified maximum # of parts
 152 our %audit_profile=(
 153                 "btw"   =>[],
 154                 "silent"=>["=btw"   ,"did"],
 155                 "log"   =>["=silent","syslog"],
 156                 "bell"  =>["=log"   ,"bell"],
 157                 "sms"   =>["=bell"  ,"sms=1"],
 158                 "crit"  =>["=sms"   ,"sms=3"],
 159                 );
 160 # Try the squeezing methods in this order:
 161 our @sms_squeezes=(
 162                 { "SqueezeControl"=>"noconv"                         },
 163                 { "SqueezeControl"=>"conv"  ,"SQZ_OPTIMIZE_LEVEL"=>0 },
 164                 { "SqueezeControl"=>"conv"  ,"SQZ_OPTIMIZE_LEVEL"=>1 },
 165                 { "SqueezeControl"=>"med"   ,"SQZ_OPTIMIZE_LEVEL"=>0 },
 166                 { "SqueezeControl"=>"med"   ,"SQZ_OPTIMIZE_LEVEL"=>1 },
 167                 { "SqueezeControl"=>"max"   ,"SQZ_OPTIMIZE_LEVEL"=>0 },
 168                 { "SqueezeControl"=>"max"   ,"SQZ_OPTIMIZE_LEVEL"=>1 },
 169                 );
 170 # Hostnames where we had alternate e-mail addresses:
 171 our @alternates_host=(
 172                 );
 173 # Override DNS blacklists:
 174 our @dnsbl_whitelist=(
 175                 "64.49.222.22",         # mail.pm.org: rackspace.com.spam-support.blackholes.five-ten-sg.com.
 176                 "208.147.243.5",        # gambit.liquidcomm.net: cw.net.spam-support.blackholes.five-ten-sg.com.
 177                 "205.139.198.11",       # eniac.disaster.com: cw.net.spam-support.blackholes.five-ten-sg.com.
 178                 "127.0.0.2",                    # 2.0.0.127.relays.ordb.org.
 179                 "65.113.40.131",        # bozo.vmware.com: qwest.net.spam-support.blackholes.five-ten-sg.com.
 180                 "66.218.85.33",         # mta2.wss.scd.yahoo.com: yahoo.com.spam.blackholes.five-ten-sg.com.
 181                 );
 182
 183 our $Audit;     # imported
 184 our $procmailFROM_MAILER;       # imported
 185 our $store_ignorenewmail;       # imported
 186 our $store_profile;     # imported
 187 our $store_ignore;      # imported
 188 sub audit
 189 {
 190         $store_profile=undef();
 191
 192         # never spawn new mail if FROM_MAILER
 193         # $isFROM_MAILER postponed after maillists as they may look as FROM_MAILER
 194         #use re 'debug';
 195         my $isFROM_MAILER=$Audit->header()=~/$procmailFROM_MAILER/mio;
 196         $store_ignorenewmail=(0
 197                         || $isFROM_MAILER
 198                         || headerhas "From",'<Regexp:^owner->'
 199                         );
 200
 201         # spam honeypots
 202         return if did sub {
 203                 # Do not local $store_file as it is our-imported
 204                 $store_profile="log";
 205                 local $_;
 206                 store "=spam".";virus=$_"            if $_=clamscan();
 207                 store "=spam".";spamassassin".($_ eq 1 ? "" : "=$_") if $_=spamassassin();
 208                 store "=spam".";$_"                  if $_=dnsbl '.relays.ordb.org.' ,1;        # all hosts
 209                 store "=spam".";$_"                  if $_=dnsbl '.blackholes.mail-abuse.org.' ,1;      # all hosts
 210                 # we don't check all hosts as they can be "dialup" category, FIXME: check for it
 211 #               store "=spam".";$_"                  if $_=dnsbl '.blackholes.five-ten-sg.com.',0; # just first
 212                 # I don't send viruses but viruses propagate mails of mine
 213                 store "=spam".";ravmd"               if headeris "X-Mailer",'ravmd/8.3.2';
 214                 };
 215         $store_profile=undef();
 216
 217         # spam detection
 218         return if did sub {
 219                 # Do not local $store_file as it is our-imported
 220                 $store_profile="silent";
 221                 local $_;
 222                 store "=spam".($_ eq 1 ? "" : ";$_")      if $_=spamassassin();
 223                 };
 224         $store_profile=undef();
 225         return if did sub {
 226                 # Do not local $store_file as it is our-imported
 227                 $store_profile="silent";
 228                 local $_;
 229                 store "=spam"                      .";$_","log" if $_=dnsbl '.relays.ordb.org.' ,1;     # all hosts
 230                 store "=spam"                      .";$_","log" if $_=dnsbl '.blackholes.mail-abuse.org.' ,1;   # all hosts
 231                 # we don't check all hosts as they can be "dialup" category, FIXME: check for it
 232                 store "=spam"                      .";$_","log" if $_=dnsbl '.blackholes.five-ten-sg.com.',0; # just first
 233                 # I don't send viruses but viruses propagate mails of mine
 234                 store "=spam"                                   if headeris "X-Mailer",'ravmd/8.3.2';
 235                 };
 236         $store_profile=undef();
 237
 238         # ppl-wished foreign remapping, Reply-To is left untouched!
 239         # FIXME: modifications are now being dropped by &write_message!
 240         header_remap("From",{
 241                         'RECEIVED@ADDRESS.TLD'=>'MAP_TO@ADDRESS.TLD',
 242                         });
 243
 244         # My obsolete e-mail addresses
 245         store_muttrc_alternates "=redirect-","btw";
 246
 247         # nasty public lists with $store_ignore
 248         {
 249                 # Do not local $store_file as it is our-imported
 250                 $store_profile="log";
 251                 local $store_ignore;
 252                 $store_ignore="smsmail"    if 1==$Audit->body() && length(join "",$Audit->body())<180;  # SMS mail
 253                 $store_ignore="list-moron" if grep { headeris "From",$_; } qw(
 254                                 <SOMEONE@SOMEWHERE.COM>
 255                                 );
 256
 257                 store "=LOCALNAME"         if headeris  "Sender"   ,'<OWNER-XYZZY@DOMAIN.TLD>';
 258                 }
 259         $store_profile=undef();
 260
 261         # lists
 262         store "=LIST","log"          if headeris "List-Id"  ,'<SOME.ID.OF.THE.LIST>';
 263
 264         if (($isFROM_MAILER && !did) || !did) {
 265                 lmtp_deliver $lmtp_admin,$lmtp_pwd,$lmtp_user_from,$lmtp_user_to;
 266                 }
 267
 268         store "=errm","bell"         if $isFROM_MAILER && !did();
 269
 270         if (!did) {
 271                 store "==","sms";
 272                 spamassassin "$HOME/bin/sa-learn --ham";
 273                 }
 274 }
 275
 276 sub audit_sms_address
 277 {
 278 my($obj)=@_;
 279
 280         my $address=$obj->address();
 281         if (my $alternates=muttrc_get("alternates")) {
 282                 return "I" if $address=~/$alternates/si;
 283                 }
 284         my %aliases=muttrc_aliases();
 285         if (my $alias=$aliases{lc $address}) {
 286                 local $_=$alias;
 287                 s/\b(Bus)siness$/$1/i;
 288                 s/\.ident$//i;
 289                 return $_;
 290                 }
 291         local $_=$address;
 292         s/\.cz$//i;
 293         return $_;
 294 }
 295
 296 # $args{"from"}
 297 # $args{"subject"}
 298 # $args{"body"}
 299 sub audit_sms
 300 {
 301 my(%args)=@_;
 302
 303         my $from=(@{$args{"from"}} ? join(",",map({ audit_sms_address($_); } @{$args{"from"}})) : "?");
 304         local $_;
 305
 306         $_=$args{"subject"};
 307         # headers
 308         s/(?:Re|Aw|Odp|Fw|Fwd|OT)(?:\[\d+\])?://ig;
 309         # former subject
 310         s/\bbylo:.*$//i;
 311         s/\[\s*WAS:.*\]\s*$//i;
 312         # trim
 313         s/^\s*//s;
 314         s/\s*$//s;
 315         my $subject=$_;
 316
 317         $_=$args{"body"};
 318         # max. 9 lines of .sig
 319         s/\n-- (?:\n[^\n]*){0,9}$//gs;
 320         # "Original Message"/"Puvodni zprava" etc. up to empty line
 321         # "- - - Original message: - - -" is by "Lotus Notes Release 5.0.5  September 22, 2000"
 322         s/(^|\n)[\s^\n]*(?:-----[\w\s]*-----|- - - Original message: - - -)[\s^\n]*(?:\n[^\n]+)*\n{2,}(?:\s*[^>\s].*$)?/\n/gs;
 323         # Remove "..." lines (is it used by anyone except me?)
 324         s/^\Q...\E$/*/gm;
 325         # quoting "> "
 326         s/^(?:\s*[[:upper:]]{0,3}>)+.*$/*/gm;
 327         s/(?:^|\n)(?:\*\n+)+/\n*\n/gs;
 328         # attributions
 329         s/^.*\b(?:wrote|writes|napsal jste):\s*$//gm;
 330         my $body=$_;
 331
 332         return [$from,"($subject)$body"];
 333 }
 334
 335 1;