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