maps/lib/MAPS.pm

   1 #!/usr/bin/perl
   2 #################################################################################
   3 #
   4 # File:         $RCSfile: MAPS.pm,v $
   5 # Revision:     $Revision: 1.1 $
   6 # Description:  Main module for Mail Authentication and Permission System (MAPS)
   7 # Author:       Andrew@DeFaria.com
   8 # Created:      Fri Nov 29 14:17:21  2002
   9 # Modified:     $Date: 2013/06/12 14:05:47 $
  10 # Language:     perl
  11 #
  12 # (c) Copyright 2000-2018, Andrew@DeFaria.com, all rights reserved.
  13 #
  14 ################################################################################
  15 package MAPS;
  16
  17 use strict;
  18 use warnings;
  19
  20 use DBI;
  21 use Carp;
  22 use FindBin;
  23 use Exporter;
  24
  25 use MAPSLog;
  26 use MIME::Entity;
  27
  28 use Display;
  29 use MyDB;
  30 use Utils;
  31 use DateUtils;
  32
  33 use base qw(Exporter);
  34
  35 our $db;
  36
  37 our $VERSION = '2.0';
  38
  39 # Globals
  40 my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
  41 my %useropts;
  42
  43 our @EXPORT = qw(
  44   Add2Blacklist
  45   Add2Nulllist
  46   Add2Whitelist
  47   AddEmail
  48   AddList
  49   AddLog
  50   AddUser
  51   AddUserOptions
  52   Blacklist
  53   CheckEmail
  54   CleanEmail
  55   CleanLog
  56   CleanList
  57   CountEmail
  58   CountList
  59   CountLog
  60   CountLogDistinct
  61   Decrypt
  62   DeleteEmail
  63   DeleteList
  64   Encrypt
  65   FindEmail
  66   FindList
  67   FindLog
  68   FindUser
  69   FindUsers
  70   ForwardMsg
  71   GetContext
  72   GetEmail
  73   GetList
  74   GetLog
  75   GetNextSequenceNo
  76   GetRows
  77   GetUser
  78   GetUserOptions
  79   ListLog
  80   ListUsers
  81   Login
  82   Nulllist
  83   OnBlacklist
  84   OnNulllist
  85   OnWhitelist
  86   OptimizeDB
  87   ReadMsg
  88   ResequenceList
  89   ReturnList
  90   ReturnMsg
  91   ReturnMessages
  92   ReturnSenders
  93   SaveMsg
  94   SearchEmails
  95   SetContext
  96   Space
  97   UpdateList
  98   UpdateUser
  99   UpdateUserOptions
 100   UserExists
 101   Whitelist
 102 );
 103
 104 my $mapsbase = "$FindBin::Bin/..";
 105
 106 # Insternal routines
 107 sub _cleanTables($$;$) {
 108   my ($table, $timestamp, $dryrun) = @_;
 109
 110   my $condition = "userid = '$userid' and timestamp < '$timestamp'";
 111
 112   if ($dryrun) {
 113     return $db->count($table, $condition);
 114   } else {
 115     my ($count, $msg) = $db->delete($table, $condition);
 116
 117     return $count;
 118   } # if
 119 } # _cleanTables
 120
 121 sub _retention2Days($) {
 122   my ($retention) = @_;
 123
 124   # Of the retnetion periods I'm thinking of where they are <n> and then
 125   # something like (days|weeks|months|years) none are tricky except for months
 126   # because months, unlike (days|weeks|years) are ill-defined. Are there 28, 29
 127   # 30 or 31 days in a month? Days are simple <n> days. Weeks are simple <n> * 7
 128   # days. Years are simple - just change the year (a little oddity of 365 or
 129   # 366) days this year? To keep things simple, we will ignore the oddities of
 130   # leap years and just use 30 for number of days in month. We really don't need
 131   # to be that accurate here...
 132   #
 133   # BTW we aren't checking for odd things like 34320 weeks or 5000 years...
 134   if ($retention =~ /(\d+)\s+(day|days)/) {
 135     return $1;
 136   } elsif ($retention =~ /(\d+)\s+(week|weeks)/){
 137     return $1 * 7;
 138   } elsif ($retention =~ /(\d+)\s+(month|months)/) {
 139     return $1 * 30;
 140   } elsif ($retention =~ /(\d+)\s+(year|years)/) {
 141     return $1 * 365;
 142   } # if
 143 } # _retention2Days
 144
 145 sub _getnext() {
 146   return $db->getnext;
 147 } # _getnext
 148
 149 sub OpenDB($$) {
 150   my ($username, $password) = @_;
 151
 152   my $dbname   = 'MAPS';
 153   my $dbserver = $ENV{MAPS_SERVER} || 'localhost';
 154
 155   $db = MyDB->new($username, $password, $dbname, $dbserver);
 156
 157   croak "Unable to instantiate MyDB ($username\@$dbserver:$dbname)" unless $db;
 158
 159   return;
 160 } # OpenDB
 161
 162 BEGIN {
 163   my $MAPS_username = "maps";
 164   my $MAPS_password = "spam";
 165
 166   OpenDB($MAPS_username, $MAPS_password);
 167 } # BEGIN
 168
 169 sub Add2Blacklist(%) {
 170   my (%params) = @_;
 171
 172   # Add2Blacklist will add an entry to the blacklist
 173   # First SetContext to the userid whose black list we are adding to
 174   SetContext($params{userid});
 175
 176   # Add to black list
 177   $params{sequence} = 0;
 178   my ($err, $msg) = AddList(%params);
 179
 180   # Log that we black listed the sender
 181   Info("Added $params{sender} to " . ucfirst $params{userid} . "'s black list");
 182
 183   # Delete old emails
 184   my $count = DeleteEmail(
 185     userid => $params{userid},
 186     sender => $params{sender},
 187   );
 188
 189   # Log out many emails we managed to remove
 190   Info("Removed $count emails from $params{sender}");
 191
 192   return $count;
 193 } # Add2Blacklist
 194
 195 sub Add2Nulllist(%) {
 196   my (%params) = @_;
 197
 198   # First SetContext to the userid whose null list we are adding to
 199   SetContext($params{userid});
 200
 201   # Add to null list
 202   $params{sequence} = 0;
 203   my ($err, $msg) = AddList(%params);
 204
 205   # Log that we null listed the sender
 206   Info("Added $params{sender} to " . ucfirst $params{userid }. "'s null list");
 207
 208   # Delete old emails
 209   my $count = DeleteEmail(
 210     userid => $params{userid},
 211     sender => $params{sender},
 212   );
 213
 214   # Log out many emails we managed to remove
 215   Info("Removed $count emails from $params{sender}");
 216
 217   return;
 218 } # Add2Nulllist
 219
 220 sub Add2Whitelist(%) {
 221   my (%params) = @_;
 222
 223   # Add2Whitelist will add an entry to the whitelist
 224   # First SetContext to the userid whose white list we are adding to
 225   SetContext($params{userid});
 226
 227   # Add to white list
 228   $params{sequence} = 0;
 229
 230   my ($err, $msg) = AddList(%params);
 231
 232   return -$err, $msg if $err;
 233
 234   # Log that we registered a user
 235   Logmsg(
 236     userid  => $params{userid},
 237     type    => 'registered',
 238     sender  => $params{sender},
 239     message => 'Registered new sender',
 240   );
 241
 242   # Check to see if there are any old messages to deliver
 243   ($err, $msg) = $db->find('email', "sender = '$params{sender}'", ['userid', 'sender', 'data']);
 244
 245   return ($err, $msg) if $err;
 246
 247   # Deliver old emails
 248   my $messages = 0;
 249   my $status   = 0;
 250
 251   while (my $rec = $db->getnext) {
 252     last unless $rec->{userid};
 253
 254     $status = Whitelist($rec->{sender}, $rec->{data});
 255
 256     last if $status;
 257
 258     $messages++;
 259   } # while
 260
 261   # Return if we has a problem delivering email
 262   return -1, 'Problem delivering some email' if $status;
 263
 264   # Remove delivered messages
 265   DeleteEmail(
 266     userid => $params{userid},
 267     sender => $params{sender},
 268   );
 269
 270   return $messages, 'Messages delivered';
 271 } # Add2Whitelist
 272
 273 sub AddEmail(%) {
 274   my (%rec) = @_;
 275
 276   CheckParms(['userid', 'sender', 'subject', 'data'], \%rec);
 277
 278   $rec{timestamp} = UnixDatetime2SQLDatetime(scalar(localtime));
 279
 280   return $db->add('email', %rec);
 281 } # AddEmail
 282
 283 sub AddList(%) {
 284   my (%rec) = @_;
 285
 286   CheckParms(['userid', 'type', 'sender', 'sequence'], \%rec);
 287
 288   croak "Type $rec{type} not valid. Must be one of white, black or null"
 289     unless $rec{type} =~ /(white|black|null)/;
 290
 291   croak "Sender must contain \@" unless $rec{sender} =~ /\@/;
 292
 293   $rec{retention} //= '';
 294   $rec{retention}   = lc $rec{retention};
 295
 296   $rec{hit_count} //= $db->count(
 297     'email',
 298     "userid = '$rec{userid}' and sender like '%$rec{sender}%'"
 299   );
 300
 301   ($rec{pattern}, $rec{domain}) = split /\@/, delete $rec{sender};
 302
 303   $rec{sequence} = GetNextSequenceNo(%rec);
 304
 305   $rec{last_hit} //= UnixDatetime2SQLDatetime(scalar (localtime));
 306
 307   return $db->add('list', %rec);
 308 } # AddList
 309
 310 sub AddLog(%) {
 311   my (%params) = @_;
 312
 313   # Some email senders are coming in mixed case. We don't want that
 314   $params{pattern} = $params{pattern} ? lc $params{pattern} : '';
 315   $params{domain}  = $params{domain}  ? lc $params{domain}  : '';
 316
 317   $params{timestamp} = UnixDatetime2SQLDatetime(scalar(localtime));
 318
 319   return $db->add('log', %params);
 320 } # AddLog
 321
 322 sub AddUser(%) {
 323   my (%rec) = @_;
 324
 325   CheckParms(['userid', 'name', 'email', 'password'], \%rec);
 326
 327   return 1 if UserExists($rec{userid});
 328
 329   return $db->add('user', %rec);
 330 } # Adduser
 331
 332 sub AddUserOptions(%) {
 333   my (%rec) = @_;
 334
 335   croak('Userid is required') unless $rec{userid};
 336   croak('No options to add')  unless $rec{options};
 337
 338   return (1, "User doesn't exists") unless UserExist($rec{userid});
 339
 340   my %useropts = delete $rec{userid};
 341   my %opts     = delete $rec{options};
 342
 343   my ($err, $msg);
 344
 345   for my $key (%opts) {
 346     $useropts{name}  = $_;
 347     $useropts{value} = $opts{$_};
 348
 349     ($err, $msg) = $db->add('useropts', %useropts);
 350
 351     last if $err;
 352   } # for
 353
 354   return ($err, $msg) if $err;
 355   return;
 356 } # AddUserOptions
 357
 358 sub Blacklist(%) {
 359   # Blacklist will send a message back to the $sender telling them that
 360   # they've been blacklisted. Currently we save a copy of the message.
 361   # In the future we should just disregard the message.
 362   my (%rec) = @_;
 363
 364   # Check to see if this sender has already emailed us.
 365   my $msg_count = $db->count('email', "userid='$rec{userid}' and sender like '%$rec{sender}%'");
 366
 367   if ($msg_count < 5) {
 368     # Bounce email
 369     my @spammsg = split "\n", $rec{data};
 370
 371     SendMsg(
 372       userid  => $rec{userid},
 373       sender  => $rec{sender},
 374       subject => 'Your email has been discarded by MAPS',
 375       msgfile => "$mapsbase/blacklist.html",
 376       data    => $rec{data},
 377     );
 378
 379     Logmsg(
 380       userid  => $userid,
 381       type    => 'blacklist',
 382       sender  => $rec{sender},
 383       message => 'Sent blacklist reply',
 384     );
 385   } else {
 386     Logmsg(
 387       userid  => $userid,
 388       type    => 'mailloop',
 389       sender  => $rec{sender},
 390       message => 'Mail loop encountered',
 391     );
 392   } # if
 393
 394   $rec{hit_count}++ if $rec{sequence};
 395
 396   RecordHit(
 397     userid    => $userid,
 398     type      => 'black',
 399     sequence  => $rec{sequence},
 400     hit_count => $rec{hit_count},
 401   );
 402
 403   return;
 404 } # Blacklist
 405
 406 sub CheckEmail(;$$) {
 407   my ($username, $domain) = @_;
 408
 409   return lc "$username\@$domain" if $username and $domain;
 410
 411   # Check to see if a full email address in either $username or $domain
 412   if ($username) {
 413     if ($username =~ /(.*)\@(.*)/) {
 414       return lc "$1\@$2";
 415     } else {
 416       return lc "$username\@";
 417     } # if
 418   } elsif ($domain) {
 419     if ($domain =~ /(.*)\@(.*)/) {
 420       return lc  "$1\@$2";
 421     } else {
 422       return "\@$domain";
 423     } # if
 424   } # if
 425 } # CheckEmail
 426
 427 sub CheckOnList2 ($$;$) {
 428   # CheckOnList will check to see if the $sender is on the list.  Return 1 if
 429   # found 0 if not.
 430   my ($listtype, $sender, $update) = @_;
 431
 432   $update //= 1;
 433
 434   my ($status, $rule, $sequence);
 435
 436   my $table      = 'list';
 437   my $condition  = "userid='$userid' and type='$listtype'";
 438
 439   my ($err, $errmsg) = $db->find($table, $condition, '*', 'order by sequence');
 440
 441   my ($email_on_file, $rec);
 442
 443   while ($rec = $db->getnext) {
 444     unless ($rec->{domain}) {
 445       $email_on_file = $rec->{pattern};
 446     } else {
 447       unless ($rec->{pattern}) {
 448         $email_on_file = '@' . $rec->{domain};
 449       } else {
 450         $email_on_file = $rec->{pattern} . '@' . $rec->{domain};
 451       } # if
 452     } # unless
 453
 454     # Escape some special characters
 455     $email_on_file =~ s/\@/\\@/;
 456     $email_on_file =~ s/^\*/.\*/;
 457
 458     # We want to terminate the search string with a "$" iff there's an
 459     # "@" in there. This is because some "email_on_file" may have no
 460     # domain (e.g. "mailer-daemon" with no domain). In that case we
 461     # don't want to terminate the search string with a "$" rather we
 462     # wish to terminate it with an "@". But in the case of say
 463     # "@ti.com" if we don't terminate the search string with "$" then
 464     # "@ti.com" would also match "@tixcom.com"!
 465     my $search_for = $email_on_file =~ /\@/
 466                    ? "$email_on_file\$"
 467                    : !defined $rec->{domain}
 468                    ? "$email_on_file\@"
 469                    : $email_on_file;
 470     if ($sender and $sender =~ /$search_for/i) {
 471       $status = 1;
 472
 473       $rec->{hit_count} //= 0;
 474
 475       RecordHit(
 476         userid    => $userid,
 477         type      => $listtype,
 478         sequence  => $rec->{sequence},
 479         hit_count => $rec->{hit_count} + 1,
 480       ) if $update;
 481
 482       last;
 483     } # if
 484   } # while
 485
 486   return ($status, $rec);
 487 } # CheckOnList2
 488
 489 sub CheckOnList ($$;$) {
 490   # CheckOnList will check to see if the $sender is on the list.  Return 1 if
 491   # found 0 if not.
 492   my ($listtype, $sender, $update) = @_;
 493
 494   $update //= 1;
 495
 496   my $status = 0;
 497   my ($rule, $sequence);
 498
 499   my $table      = 'list';
 500   my $condition  = "userid='$userid' and type='$listtype'";
 501
 502   my ($err, $errmsg) = $db->find($table, $condition, '*', 'order by sequence');
 503
 504   my ($email_on_file, $rec);
 505
 506   while ($rec = $db->getnext) {
 507     unless ($rec->{domain}) {
 508       $email_on_file = $rec->{pattern};
 509     } else {
 510       unless ($rec->{pattern}) {
 511         $email_on_file = '@' . $rec->{domain};
 512       } else {
 513         $email_on_file = $rec->{pattern} . '@' . $rec->{domain};
 514       } # if
 515     } # unless
 516
 517     # Escape some special characters
 518     $email_on_file =~ s/\@/\\@/;
 519     $email_on_file =~ s/^\*/.\*/;
 520
 521     # We want to terminate the search string with a "$" iff there's an
 522     # "@" in there. This is because some "email_on_file" may have no
 523     # domain (e.g. "mailer-daemon" with no domain). In that case we
 524     # don't want to terminate the search string with a "$" rather we
 525     # wish to terminate it with an "@". But in the case of say
 526     # "@ti.com" if we don't terminate the search string with "$" then
 527     # "@ti.com" would also match "@tixcom.com"!
 528     my $search_for = $email_on_file =~ /\@/
 529                    ? "$email_on_file\$"
 530                    : !defined $rec->{domain}
 531                    ? "$email_on_file\@"
 532                    : $email_on_file;
 533     if ($sender and $sender =~ /$search_for/i) {
 534       my $comment = $rec->{comment} ? " - $rec->{comment}" : '';
 535
 536       $rule   = "Matching rule: ($listtype:$rec->{sequence}) \"$email_on_file$comment\"";
 537       $rule  .= " - $rec->{comment}" if $rec->{comment};
 538       $status = 1;
 539
 540       $rec->{hit_count} //= 0;
 541
 542       RecordHit(
 543         userid    => $userid,
 544         type      => $listtype,
 545         sequence  => $rec->{sequence},
 546         hit_count => $rec->{hit_count} + 1,
 547       ) if $update;
 548
 549       last;
 550     } # if
 551   } # while
 552
 553   return ($status, $rule, $rec->{sequence}, $rec->{hit_count});
 554 } # CheckOnList
 555
 556 sub CleanEmail($;$) {
 557   my ($timestamp, $dryrun) = @_;
 558
 559   return _cleanTables 'email', $timestamp, $dryrun;
 560 } # ClearEmail
 561
 562 sub CleanLog($;$) {
 563   my ($timestamp, $dryrun) = @_;
 564
 565   return _cleanTables('log', $timestamp, $dryrun);
 566 } # CleanLog
 567
 568 sub CleanList(%) {
 569   my (%params) = @_;
 570
 571   CheckParms(['userid', 'type'], \%params);
 572
 573   my $dryrunstr = $params{dryrun} ? '(dryrun)' : '';
 574
 575   my $table     = 'list';
 576   my $condition = "userid='$params{userid}' and type='$params{type}'";
 577   my $count     = 0;
 578   my $msg;
 579
 580   # First let's go through the list to see if we have an domain level entry
 581   # (e.g. @spammer.com) and also individual entries (baddude@spammer.com) then
 582   # we don't really need any of the individual entries since the domain block
 583   # covers them.
 584   $db->find($table, $condition, ['domain'], ' and pattern is null');
 585
 586   while (my $domains = $db->getnext) {
 587     for my $recs ($db->get($table, $condition, ['sequence', 'pattern', 'domain'],
 588                       " and domain='$domains->{domain}' and pattern is not null")) {
 589       if (@$recs and not $params{dryrun}) {
 590         for my $rec (@$recs) {
 591           DeleteList(
 592             userid   => $params{userid},
 593             type     => $params{type},
 594             sequence => $rec->{sequence},
 595           );
 596
 597           $params{log}->msg("Deleted $params{userid}:$params{type}:$rec->{sequence} "
 598                             .  "$rec->{pattern}\@$rec->{domain} $dryrunstr")
 599             if $params{log};
 600
 601           $count++;
 602         } # for
 603       } elsif (@$recs) {
 604         if ($params{log}) {
 605           $params{log}->msg("The domain $domains->{domain} has the following subrecords");
 606
 607           for my $rec (@$recs) {
 608             $params{log}->msg("$rec->{pattern}\@$rec->{domain}");
 609           } # for
 610         } # if
 611       } # if
 612     } # for
 613   } # while
 614
 615   $condition = "userid='$params{userid}' and type='$params{type}' and retention is not null";
 616
 617   # First see if anything needs to be deleted
 618   ($count, $msg) = $db->count($table, $condition);
 619
 620   return 0 unless $count;
 621
 622   $count = 0;
 623
 624   my ($err, $errmsg) = $db->find($table, $condition);
 625
 626   croak "Unable to find $params{type} entries for $condition - $errmsg" if $err;
 627
 628   my $todaysDate = Today2SQLDatetime;
 629
 630   while (my $rec = $db->getnext) {
 631     my $days = _retention2Days($rec->{retention});
 632
 633     my $agedDate = SubtractDays($todaysDate, $days);
 634
 635     # If last_hit < retentiondays then delete
 636     if (Compare($rec->{last_hit}, $agedDate) == -1) {
 637       unless ($params{dryrun}) {
 638         DeleteList(
 639           userid   => $params{userid},
 640           type     => $params{type},
 641           sequence => $rec->{sequence},
 642         );
 643
 644         if ($params{log}) {
 645           $rec->{pattern} //= '';
 646           $rec->{domain}  //= '';
 647
 648           $params{log}->msg("Deleted $rec->{userid}:$params{type}:$rec->{sequence} "
 649                                   .  "$rec->{pattern}\@$rec->{domain} $dryrunstr");
 650           $params{log}->dbug("last hit = $rec->{last_hit} < agedDate = $agedDate");
 651         } # if
 652       } # unless
 653
 654       $count++;
 655     } else {
 656       $params{log}->dbug("$rec->{userid}:$params{type}:$rec->{sequence}: nodelete $dryrunstr "
 657                        . "last hit = $rec->{last_hit} >= agedDate = $agedDate")
 658         if $params{log};
 659     } # if
 660   } # while
 661
 662   ResequenceList(
 663     userid => $params{userid},
 664     type   => $params{type},
 665   ) if $count && !$params{dryrun};
 666
 667   return $count;
 668 } # CleanList
 669
 670 sub CountEmail(%) {
 671   my (%params) = @_;
 672
 673   CheckParms(['userid'], \%params);
 674
 675   my $table      = 'email';
 676   my $condition  = "userid='$params{userid}'";
 677      $condition .= " and $params{additional}" if $params{additional};
 678
 679   return $db->count($table, $condition);
 680 } # CountEmail
 681
 682 sub CountList(%) {
 683   my (%params) = @_;
 684
 685   CheckParms(['userid', 'type'], \%params);
 686
 687   my $table     = 'list';
 688   my $condition = "userid='$params{userid}' and type='$params{type}'";
 689
 690   return $db->count($table, $condition);
 691 } # CountList
 692
 693 sub CountLog(%) {
 694   my (%params) = @_;
 695
 696   CheckParms(['userid'], \%params);
 697
 698   my ($additional_condition) = delete $params{additional} || '';
 699
 700   my $condition  = "userid='$userid'";
 701      $condition .= " and $additional_condition" if $additional_condition;
 702
 703   return $db->count('log', $condition);
 704 } # CountLog
 705
 706 sub CountLogDistinct(%) {
 707   my (%params) = @_;
 708
 709   CheckParms(['userid', 'column'], \%params);
 710
 711   my ($additional_condition) = delete $params{additional} || '';
 712
 713   my $condition  = "userid='$userid'";
 714      $condition .= " and $additional_condition" if $additional_condition;
 715
 716   return $db->count_distinct('log', $params{column}, $condition);
 717 } # CountLog
 718
 719 sub Decrypt ($$) {
 720   my ($password, $userid) = @_;
 721
 722   return $db->decode($password, $userid);
 723 } # Decrypt
 724
 725 sub DeleteEmail(%) {
 726   my (%rec) = @_;
 727
 728   my $table = 'email';
 729
 730   CheckParms(['userid', 'sender'], \%rec);
 731
 732   my ($username, $domain) = split /@/, $rec{sender};
 733   my $condition;
 734
 735   if ($username) {
 736     $condition = "userid = '$rec{userid}' and sender = '$rec{sender}'";
 737   } else {
 738     $condition = "userid = '$rec{userid}' and sender like '%\@$domain'";
 739   } # if
 740
 741   return $db->delete($table, $condition);
 742 } # DeleteEmail
 743
 744 sub DeleteList(%) {
 745   my (%rec) = @_;
 746
 747   CheckParms(['userid', 'type', 'sequence'], \%rec);
 748
 749   my $condition = "userid = '$rec{userid}' and "
 750                 . "type = '$rec{type}' and "
 751                 . "sequence = $rec{sequence}";
 752
 753   return $db->delete('list', $condition);
 754 } # DeleteList
 755
 756 sub Encrypt($$) {
 757   my ($password, $userid) = @_;
 758
 759   return $db->encode($password, $userid);
 760 } # Encrypt
 761
 762 sub FindEmail(%) {
 763   my (%params) = @_;
 764
 765   CheckParms(['userid'], \%params);
 766
 767   my $table      = 'email';
 768   my $condition  = "userid='$params{userid}'";
 769      $condition .= " and sender='$params{sender}'"       if $params{sender};
 770      $condition .= " and timestamp='$params{timestamp}'" if $params{timestamp};
 771
 772   return $db->find($table, $condition);
 773 } # FindEmail
 774
 775 sub FindList(%) {
 776   my (%params) = @_;
 777
 778   my ($type, $sender) = @_;
 779
 780   CheckParms(['userid', 'type'], \%params);
 781
 782   my $table     = 'list';
 783   my $condition = "userid='$params{userid}' and type='$params{type}'";
 784
 785   if ($params{sender}) {
 786     my ($username, $domain) = split /\@/, $params{sender};
 787
 788     # Split will return '' if either username or domain is missing. This messes
 789     # up SQL's find as '' ~= NULL. Therefore we only specify username or domain
 790     # if it is present.
 791     $condition .= " and pattern='$username'" if $username;
 792     $condition .= " and domain='$domain'"    if $domain;
 793   } # if
 794
 795   return $db->find($table, $condition);
 796 } # FindList
 797
 798 sub FindLog($) {
 799   my ($how_many) = @_;
 800
 801   my $start_at = 0;
 802   my $end_at   = CountLog(
 803     userid => $userid,
 804   );
 805
 806   if ($how_many < 0) {
 807     $start_at = $end_at - abs ($how_many);
 808     $start_at = 0 if ($start_at < 0);
 809   } # if
 810
 811   my $table      = 'log';
 812   my $condition  = "userid='$userid'";
 813   my $additional = "order by timestamp limit $start_at, $end_at";
 814
 815   return $db->find($table, $condition, '*', $additional);
 816 } # FindLog
 817
 818 sub FindUser(%) {
 819   my (%params) = @_;
 820
 821   my $table     = 'user';
 822   my $condition = '';
 823
 824   $condition = "userid='$userid'" if $params{userid};
 825
 826   return $db->find($table, $condition, $params{fields});
 827 } # FindUser
 828
 829 sub FindUsers() {
 830   return $db->find('user', '', ['userid']);
 831 } # FindUsers
 832
 833 sub GetEmail() {
 834   goto &_getnext;
 835 } # GetEmail
 836
 837 sub GetContext() {
 838   return $userid;
 839 } # GetContext
 840
 841 sub GetList() {
 842   goto &_getnext;
 843 } # GetList
 844
 845 sub GetLog() {
 846   goto &_getnext;
 847 } # GetLog
 848
 849 sub GetNextSequenceNo(%) {
 850   my (%rec) = @_;
 851
 852   CheckParms(['userid', 'type'], \%rec);
 853
 854   my $table     = 'list';
 855   my $condition = "userid='$rec{userid}' and type='$rec{type}'";
 856
 857   my $count = $db->count('list', $condition);
 858
 859   return $count + 1;
 860 } # GetNextSequenceNo
 861
 862 sub GetUser() {
 863   goto &_getnext;
 864 } # GetUser
 865
 866 sub GetUserInfo($) {
 867   my ($userid) = @_;
 868
 869   return %{$db->getone('user', "userid='$userid'", ['name', 'email'])};
 870 } # GetUserInfo
 871
 872 sub GetUserOptions($) {
 873   my ($userid) = @_;
 874
 875   my $table     = 'useropts';
 876   my $condition = "userid='$userid'";
 877
 878   $db->find($table, $condition);
 879
 880   my %useropts;
 881
 882   while (my $rec = $db->getnext) {
 883     $useropts{$rec->{name}} = $rec->{value};
 884   } # while
 885
 886   return %useropts;
 887 } # GetUserOptions
 888
 889 sub Login($$) {
 890   my ($userid, $password) = @_;
 891
 892   $password = Encrypt($password, $userid);
 893
 894   # Check if user exists
 895   my $dbpassword = UserExists($userid);
 896
 897   # Return -1 if user doesn't exist
 898   return -1 unless $dbpassword;
 899
 900   # Return -2 if password does not match
 901   if ($password eq $dbpassword) {
 902     SetContext($userid);
 903     return 0
 904   } else {
 905     return -2
 906   } # if
 907 } # Login
 908
 909 sub Nulllist($;$$) {
 910   # Nulllist will simply discard the message.
 911   my ($sender, $sequence, $hit_count) = @_;
 912
 913   RecordHit(
 914     userid    => $userid,
 915     type      => 'null',
 916     sequence  => $sequence,
 917     hit_count => ++$hit_count,
 918   ) if $sequence;
 919
 920   # Discard Message
 921   Logmsg(
 922     userid  => $userid,
 923     type    => 'nulllist',
 924     sender  => $sender,
 925     message => 'Discarded message'
 926   );
 927
 928   return;
 929 } # Nulllist
 930
 931 sub OnBlacklist($;$) {
 932   my ($sender, $update) = @_;
 933
 934   return CheckOnList2('black', $sender, $update);
 935 } # OnBlacklist
 936
 937 sub OnNulllist($;$) {
 938   my ($sender, $update) = @_;
 939
 940   return CheckOnList2('null', $sender, $update);
 941 } # CheckOnNulllist
 942
 943 sub OnWhitelist($;$$) {
 944   my ($sender, $userid, $update) = @_;
 945
 946   SetContext($userid) if $userid;
 947
 948   return CheckOnList2('white', $sender, $update);
 949 } # OnWhitelist
 950
 951 sub OptimizeDB() {
 952   my @tables = qw(email list log user useropts);
 953
 954   my ($err, $msg) = $db->lock('read', \@tables);
 955
 956   croak "Unable to lock table - $msg" if $err;
 957
 958   ($err, $msg) = $db->check(\@tables);
 959
 960   croak 'Unable to check tables ' . $msg if $err;
 961
 962   ($err, $msg) = $db->optimize(\@tables);
 963
 964   croak 'Unable to optimize tables ' . $msg if $err;
 965
 966   return $db->unlock();
 967 } # OptimizeDB
 968
 969 sub ReadMsg($) {
 970   # Reads an email message file from $input. Returns sender, subject,
 971   # date and data, which is a copy of the entire message.
 972   my ($input) = @_;
 973
 974   my $sender          = '';
 975   my $sender_long     = '';
 976   my $envelope_sender = '';
 977   my $reply_to        = '';
 978   my $subject         = '';
 979   my $data            = '';
 980   my @data;
 981
 982   # Find first message's "From " line indicating start of message
 983   while (<$input>) {
 984     chomp;
 985     last if /^From /;
 986   } # while
 987
 988   # If we hit eof here then the message was garbled. Return indication of this
 989   if (eof($input)) {
 990     $data = "Garbled message - unable to find From line";
 991     return $sender, $sender_long, $reply_to, $subject, $data;
 992   } # if
 993
 994   if (/From (\S*)/) {
 995     $envelope_sender = $1;
 996     $sender_long     = $envelope_sender;
 997   } # if
 998
 999   push @data, $_ if /^From /;
1000
1001   while (<$input>) {
1002     chomp;
1003     push @data, $_;
1004
1005     # Blank line indicates start of message body
1006     last if ($_ eq "" || $_ eq "\r");
1007
1008     # Extract sender's address
1009     if (/^from: .*/i) {
1010       $_ = substr ($_, 6);
1011
1012       $sender_long = $_;
1013
1014       if (/<(\S*)@(\S*)>/) {
1015         $sender = lc ("$1\@$2");
1016       } elsif (/(\S*)@(\S*)\ /) {
1017         $sender = lc ("$1\@$2");
1018       } elsif (/(\S*)@(\S*)/) {
1019         $sender = lc ("$1\@$2");
1020       } # if
1021     } elsif (/^subject: .*/i) {
1022       $subject = substr ($_, 9);
1023     } elsif (/^reply-to: .*/i) {
1024       $_ = substr ($_, 10);
1025       if (/<(\S*)@(\S*)>/) {
1026         $reply_to = lc ("$1\@$2");
1027       } elsif (/(\S*)@(\S*)\ /) {
1028         $reply_to = lc ("$1\@$2");
1029       } elsif (/(\S*)@(\S*)/) {
1030         $reply_to = lc ("$1\@$2");
1031       } # if
1032     } # if
1033   } # while
1034
1035   # Read message body
1036   while (<$input>) {
1037     chomp;
1038
1039     last if (/^From /);
1040     push @data, $_;
1041   } # while
1042
1043   # Set file pointer back by length of the line just read
1044   seek ($input, -length () - 1, 1) if !eof $input;
1045
1046   # Sanitize email addresses
1047   $envelope_sender =~ s/\<//g;
1048   $envelope_sender =~ s/\>//g;
1049   $envelope_sender =~ s/\"//g;
1050   $envelope_sender =~ s/\'//g;
1051   $sender          =~ s/\<//g;
1052   $sender          =~ s/\>//g;
1053   $sender          =~ s/\"//g;
1054   $sender          =~ s/\'//g;
1055   $reply_to        =~ s/\<//g;
1056   $reply_to        =~ s/\>//g;
1057   $reply_to        =~ s/\"//g;
1058   $reply_to        =~ s/\'//g;
1059
1060   # Determine best addresses
1061   $sender    = $envelope_sender if $sender eq "";
1062   $reply_to  = $sender          if $reply_to eq "";
1063
1064   return $sender, $sender_long, $reply_to, $subject, join "\n", @data;
1065 } # ReadMsg
1066
1067 sub RecordHit(%) {
1068   my (%rec) = @_;
1069
1070   CheckParms(['userid', 'type', 'sequence', ], \%rec);
1071
1072   my $current_date = UnixDatetime2SQLDatetime(scalar(localtime));
1073
1074   my $table     = 'list';
1075   my $condition = "userid='rec{userid} and type=$rec{type} and sequence='$rec{sequence}";
1076
1077   return $db->modify(
1078     table     => $table,
1079     condition => $condition,
1080     %rec,
1081   );
1082 } # RecordHit
1083
1084 sub ResequenceList(%) {
1085   my (%params) = @_;
1086
1087   CheckParms(['userid', 'type'], \%params);
1088
1089   # Data checks
1090   return 1 unless $params{type} =~ /(white|black|null)/;
1091   return 2 unless UserExists($params{userid});
1092
1093   my $table     = 'list';
1094   my $condition = "userid='$params{userid}' and type ='$params{type}'";
1095
1096   # Lock the table
1097   $db->lock('write', $table);
1098
1099   # Get all records for $userid and $type
1100   my $listrecs = $db->get($table, $condition,'*', 'order by hit_count desc');
1101
1102   # Delete all of the list entries for this $userid and $type
1103   my ($count, $msg) = $db->delete($table, $condition);
1104
1105   # Now re-add list entries renumbering them
1106   my $sequence = 1;
1107
1108   for (@$listrecs) {
1109     $_->{sequence} = $sequence++;
1110
1111     my ($err, $msg) = $db->add($table, %$_);
1112
1113     croak $msg if $err;
1114   } # for
1115
1116   $db->unlock;
1117
1118   return 0;
1119 } # ResequenceList
1120
1121 sub ReturnList(%) {
1122   my (%params) = @_;
1123
1124   CheckParms(['userid', 'type'], \%params);
1125
1126   my $start_at = delete $params{start_at} || 0;
1127   my $lines    = delete $params{lines}    || 10;
1128
1129   my $table      = 'list';
1130   my $condition  = "userid='$params{userid}' and type='$params{type}'";
1131   my $additional = "order by sequence limit $start_at, $lines";
1132
1133   return $db->get($table, $condition, '*', $additional);
1134 } # ReturnList
1135
1136 sub ReturnMsg(%) {
1137   my (%params) = @_;
1138
1139   # ReturnMsg will send back to the $sender the register message.
1140   # Messages are saved to be delivered when the $sender registers.
1141   #
1142   # Added reply_to. Previously we passed reply_to into here as sender. This
1143   # caused a problem in that we were filtering as per sender but logging it
1144   # as reply_to. We only need reply_to for SendMsg so as to honor reply_to
1145   # so we now pass in both sender and reply_to
1146
1147   CheckParms(['userid', 'sender', 'reply_to', 'subject', 'data'], \%params);
1148
1149   #my ($sender, $reply_to, $subject, $data) = @_;
1150
1151   # Check to see if this sender has already emailed us.
1152   my $msg_count = $db->count('email', "userid='$userid' and sender like '%$params{sender}%'");
1153
1154   if ($msg_count < 5) {
1155     # Return register message
1156     SendMsg(
1157       userid   => $params{userid},
1158       sender   => $params{reply_to},
1159       subject  => 'Your email has been returned by MAPS',
1160       msgfile  => "$mapsbase/register.html",
1161       data     => $params{data},
1162     ) if $msg_count == 0;
1163
1164     Logmsg(
1165       userid  => $params{userid},
1166       type    => 'returned',
1167       sender  => $params{sender},
1168       message => 'Sent register reply',
1169     );
1170
1171     # Save message
1172     SaveMsg($params{sender}, $params{subject}, $params{data});
1173   } else {
1174     Add2Nulllist($params{sender}, GetContext, "Auto Null List - Mail loop");
1175
1176     Logmsg(
1177       userid  => $params{userid},
1178       type    => 'mailloop',
1179       sender  => $params{sender},
1180       message => 'Mail loop encountered',
1181     );
1182   } # if
1183
1184   return;
1185 } # ReturnMsg
1186
1187 sub ReturnMessages(%) {
1188   my (%params) = @_;
1189
1190   CheckParms(['userid', 'sender'], \%params);
1191
1192   my $table      = 'email';
1193   my $condition  = "userid='$params{userid}' and sender='$params{sender}'";
1194   my $fields     = ['subject', 'timestamp'];
1195   my $additional = 'group by timestamp desc';
1196
1197   return $db->get($table, $condition, $fields, $additional);
1198 } # ReturnMessages
1199
1200 sub ReturnSenders(%) {
1201   my (%params) = @_;
1202   # This subroutine returns an array of senders in reverse chronological
1203   # order based on time timestamp from the log table of when we returned
1204   # their message. The complication here is that a single sender may
1205   # send multiple times in a single day. So if spammer@foo.com sends
1206   # spam @ 1 second after midnight and then again at 2 Pm there will be
1207   # at least two records in the log table saying that we returned his
1208   # email. Getting records sorted by timestamp desc will have
1209   # spammer@foo.com listed twice. But we want him listed only once, as
1210   # the first entry in the returned array. Plus we may be called
1211   # repeatedly with different $start_at's. Therefore we need to process
1212   # the whole list of returns for today, eliminate duplicate entries for
1213   # a single sender then slice the resulting array.
1214   CheckParms(['userid', 'type', 'lines'], \%params);
1215
1216   my $table      = 'log';
1217   my $condition  = "userid='$params{userid}' and type='$params{type}'";
1218   my $additional = 'order by timestamp desc';
1219
1220   $params{start_at} ||= 0;
1221
1222   if ($params{date}) {
1223     $condition .= "and timestamp > '$params{date} 00:00:00' and "
1224                .      "timestamp < '$params{date} 23:59:59'";
1225   } # if
1226
1227   $db->find($table, $condition, '*', $additional);
1228
1229   # Watch the distinction between senders (plural) and sender (singular)
1230   my %senders;
1231
1232   # Run through the results and add to %senders by sender key. This
1233   # results in a hash that has the sender in it and the first
1234   # timestamp value. Since we already sorted timestamp desc by the
1235   # above select statement, and we've narrowed it down to only log
1236   # message that occurred for the given $date, we will have a hash
1237   # containing 1 sender and the latest timestamp for the day.
1238   while (my $rec = $db->getnext) {
1239     $senders{$rec->{sender}} = $rec->{timestamp}
1240       unless $senders{$rec->{sender}};
1241   } # while
1242
1243   my (@unsorted, @senders);
1244
1245   # Here we have a hash in %senders that has email address and timestamp. In the
1246   # past we would merely create a reverse hash by timestamp and sort that. The
1247   # The problem is that it is possible for two emails to come in with the same
1248   # timestamp. By reversing the hash we clobber any row that has a dumplicte
1249   # timestamp. But we want to sort on timestamp. So first we convers this hash
1250   # to an array of hashes and then we can sort by timestamp later.
1251   while (my ($key, $value) = each %senders) {
1252     push @unsorted, {
1253       sender    => $key,
1254       timestamp => $value,
1255     };
1256   } # while
1257
1258   push @senders, $_->{sender} for sort { $b->{timestamp} cmp $a->{timestamp}} @unsorted;
1259
1260   # Finally slice for the given range
1261   my $end_at = $params{start_at} + ($params{lines} - 1);
1262
1263   $end_at = (@senders) - 1 if $end_at >= @senders;
1264
1265   return (@senders) [$params{start_at} .. $end_at];
1266 } # ReturnSenders
1267
1268 sub SaveMsg($$$) {
1269   my ($sender, $subject, $data) = @_;
1270
1271   AddEmail(
1272     userid  => $userid,
1273     sender  => $sender,
1274     subject => $subject,
1275     data    => $data,
1276   );
1277
1278   return;
1279 } # SaveMsg
1280
1281 sub SearchEmails(%) {
1282   my (%params) = @_;
1283
1284   CheckParms(['userid', 'search'], \%params);
1285
1286   my $table      = 'email';
1287   my $fields     = ['sender', 'subject', 'timestamp'];
1288   my $condition  = "userid='$params{userid}' and (sender like '\%$params{search}\%' "
1289                  . "or subject like '\%$params{search}\%')";
1290   my $additional = 'order by timestamp desc';
1291
1292   my ($err, $msg) = $db->find($table, $condition, $fields, $additional);
1293
1294   my @emails;
1295
1296   while (my $rec = $db->getnext) {
1297     push @emails, $rec;
1298   } # while
1299
1300   return @emails;
1301 } # SearchEmails
1302
1303 sub SendMsg(%) {
1304   # SendMsg will send the message contained in $msgfile.
1305   my (%params) = @_;
1306
1307   #my ($sender, $subject, $msgfile, $userid, @spammsg) = @_;
1308
1309   my @lines;
1310
1311   # Open return message template file
1312   open my $return_msg_file, '<', $params{msgfile}
1313     or die "Unable to open return msg file ($params{msgfile}): $!\n";
1314
1315   # Read return message template file and print it to $msg_body
1316   while (<$return_msg_file>) {
1317     if (/\$userid/) {
1318       # Replace userid
1319       s/\$userid/$userid/;
1320     } # if
1321     if (/\$sender/) {
1322       # Replace sender
1323       s/\$sender/$params{sender}/;
1324     } #if
1325
1326     push @lines, $_;
1327   } # while
1328
1329   close $return_msg_file;
1330
1331   # Create the message, and set up the mail headers:
1332   my $msg = MIME::Entity->build(
1333     From    => "MAPS\@DeFaria.com",
1334     To      => $params{sender},
1335     Subject => $params{subject},
1336     Type    => "text/html",
1337     Data    => \@lines
1338   );
1339
1340   # Need to obtain the spam message here...
1341   my @spammsg = split "\n", $params{data};
1342
1343   $msg->attach(
1344     Type        => "message",
1345     Disposition => "attachment",
1346     Data        => \@spammsg
1347   );
1348
1349   # Send it
1350   open my $mail, '|-', '/usr/lib/sendmail -t -oi -oem'
1351     or croak "SendMsg: Unable to open pipe to sendmail $!";
1352
1353   $msg->print(\*$mail);
1354
1355   close $mail;
1356
1357   return;
1358 } # SendMsg
1359
1360 sub SetContext($) {
1361   my ($to_user) = @_;
1362
1363   if (UserExists($to_user)) {
1364     $userid = $to_user;
1365
1366     return GetUserOptions $userid;
1367   } else {
1368     return 0;
1369   } # if
1370 } # SetContext
1371
1372 sub Space($) {
1373   my ($userid) = @_;
1374
1375   my $total_space = 0;
1376   my $table       = 'email';
1377   my $condition   = "userid='$userid'";
1378
1379   $db->find($table, $condition);
1380
1381   while (my $rec = $db->getnext) {
1382     $total_space +=
1383       length($rec->{userid})    +
1384       length($rec->{sender})    +
1385       length($rec->{subject})   +
1386       length($rec->{timestamp}) +
1387       length($rec->{data});
1388   } # while
1389
1390   return $total_space;
1391 } # Space
1392
1393 sub UpdateList(%) {
1394   my (%rec) = @_;
1395
1396   CheckParms(['userid', 'type', 'sequence'], \%rec);
1397
1398   my $table     = 'list';
1399   my $condition = "userid = '$rec{userid}' and type = '$rec{type}' and sequence = $rec{sequence}";
1400
1401   if ($rec{pattern} =~ /\@/ && !$rec{domain}) {
1402     ($rec{pattern}, $rec{domain}) = split /\@/, $rec{pattern};
1403   } elsif (!$rec{pattern} && $rec{domain} =~ /\@/) {
1404     ($rec{pattern}, $rec{domain}) = split /\@/, $rec{domain};
1405   } elsif (!$rec{pattern} && !$rec{domain}) {
1406     return "Must specify either Username or Domain";
1407   } # if
1408
1409   $rec{pattern}   //= 'null';
1410   $rec{domain}    //= 'null';
1411   $rec{comment}   //= 'null';
1412
1413   if ($rec{retention}) {
1414     $rec{retention} = lc $rec{retention};
1415   } # if
1416
1417   return $db->update($table, $condition, %rec);
1418 } # UpdateList
1419
1420 sub UpdateUser(%) {
1421   my (%rec) = @_;
1422
1423   CheckParms(['userid', 'name', 'email'], \%rec);
1424
1425   return 1 unless UserExists($rec{userid});
1426
1427   my $table = 'user';
1428   my $condition = "userid='$rec{userid}'";
1429
1430   return $db->update($table, $condition, %rec);
1431 } # UpdateUser
1432
1433 sub UpdateUserOptions ($@) {
1434   my ($userid, %options)  = @_;
1435
1436   return unless UserExists($userid);
1437
1438   my $table     = 'useropts';
1439   my $condition = "userid='$userid' and name=";
1440
1441   $db->update($table, "$condition'$_'", (name=>$_, value=>$options{$_})) for (keys %options);
1442
1443   return;
1444 } # UpdateUserOptions
1445
1446 sub UserExists($) {
1447   my ($userid) = @_;
1448
1449   return 0 unless $userid;
1450
1451   my $table     = 'user';
1452   my $condition = "userid='$userid'";
1453
1454   my $rec = $db->get($table, $condition);
1455
1456   return 0 if scalar(@$rec) == 0;
1457
1458   return $rec->[0]{password};
1459 } # UserExists
1460
1461 sub Whitelist ($$;$$) {
1462   # Whitelist will deliver the message.
1463   my ($sender, $data, $sequence, $hit_count) = @_;
1464
1465   my $userid = GetContext;
1466
1467   # Dump message into a file
1468   open my $message, '>', "/tmp/MAPSMessage.$$"
1469     or Error("Unable to open message file (/tmp/MAPSMessage.$$): $!\n"), return -1;
1470
1471   print $message $data;
1472
1473   close $message;
1474
1475   # Now call MAPSDeliver
1476   my $status = system "$FindBin::Bin/MAPSDeliver $userid /tmp/MAPSMessage.$$";
1477
1478   unlink "/tmp/MAPSMessage.$$";
1479
1480   if ($status == 0) {
1481     Logmsg(
1482       userid  => $userid,
1483       type    => 'whitelist',
1484       sender  => $sender,
1485       message => 'Delivered message',
1486     );
1487   } else {
1488     Error("Unable to deliver message - is MAPSDeliver setgid? - $!");
1489   } # if
1490
1491   $hit_count++ if $sequence;
1492
1493   RecordHit(
1494     userid   => $userid,
1495     type     => 'white',
1496     sequence => $sequence,
1497     hit_count => $hit_count,
1498   );
1499
1500   return $status;
1501 } # Whitelist
1502
1503 1;