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{sender} = $params{sender} ? lc $params{sender} : '';
 315
 316   $params{timestamp} = UnixDatetime2SQLDatetime(scalar(localtime));
 317
 318   return $db->add('log', %params);
 319 } # AddLog
 320
 321 sub AddUser(%) {
 322   my (%rec) = @_;
 323
 324   CheckParms(['userid', 'name', 'email', 'password'], \%rec);
 325
 326   return 1 if UserExists($rec{userid});
 327
 328   return $db->add('user', %rec);
 329 } # Adduser
 330
 331 sub AddUserOptions(%) {
 332   my (%rec) = @_;
 333
 334   croak('Userid is required') unless $rec{userid};
 335   croak('No options to add')  unless $rec{options};
 336
 337   return (1, "User doesn't exists") unless UserExist($rec{userid});
 338
 339   my %useropts = delete $rec{userid};
 340   my %opts     = delete $rec{options};
 341
 342   my ($err, $msg);
 343
 344   for my $key (%opts) {
 345     $useropts{name}  = $_;
 346     $useropts{value} = $opts{$_};
 347
 348     ($err, $msg) = $db->add('useropts', %useropts);
 349
 350     last if $err;
 351   } # for
 352
 353   return ($err, $msg) if $err;
 354   return;
 355 } # AddUserOptions
 356
 357 sub Blacklist(%) {
 358   # Blacklist will send a message back to the $sender telling them that
 359   # they've been blacklisted. Currently we save a copy of the message.
 360   # In the future we should just disregard the message.
 361   my (%rec) = @_;
 362
 363   # Check to see if this sender has already emailed us.
 364   my $msg_count = $db->count('email', "userid='$rec{userid}' and sender like '%$rec{sender}%'");
 365
 366   if ($msg_count < 5) {
 367     # Bounce email
 368     my @spammsg = split "\n", $rec{data};
 369
 370     SendMsg(
 371       userid  => $rec{userid},
 372       sender  => $rec{sender},
 373       subject => 'Your email has been discarded by MAPS',
 374       msgfile => "$mapsbase/blacklist.html",
 375       data    => $rec{data},
 376     );
 377
 378     Logmsg(
 379       userid  => $userid,
 380       type    => 'blacklist',
 381       sender  => $rec{sender},
 382       message => 'Sent blacklist reply',
 383     );
 384   } else {
 385     Logmsg(
 386       userid  => $userid,
 387       type    => 'mailloop',
 388       sender  => $rec{sender},
 389       message => 'Mail loop encountered',
 390     );
 391   } # if
 392
 393   $rec{hit_count}++ if $rec{sequence};
 394
 395   RecordHit(
 396     userid    => $userid,
 397     type      => 'black',
 398     sequence  => $rec{sequence},
 399     hit_count => $rec{hit_count},
 400   );
 401
 402   return;
 403 } # Blacklist
 404
 405 sub CheckEmail(;$$) {
 406   my ($username, $domain) = @_;
 407
 408   return lc "$username\@$domain" if $username and $domain;
 409
 410   # Check to see if a full email address in either $username or $domain
 411   if ($username) {
 412     if ($username =~ /(.*)\@(.*)/) {
 413       return lc "$1\@$2";
 414     } else {
 415       return lc "$username\@";
 416     } # if
 417   } elsif ($domain) {
 418     if ($domain =~ /(.*)\@(.*)/) {
 419       return lc  "$1\@$2";
 420     } else {
 421       return "\@$domain";
 422     } # if
 423   } # if
 424 } # CheckEmail
 425
 426 sub CheckOnList2 ($$;$) {
 427   # CheckOnList will check to see if the $sender is on the list.  Return 1 if
 428   # found 0 if not.
 429   my ($listtype, $sender, $update) = @_;
 430
 431   $update //= 1;
 432
 433   my ($status, $rule, $sequence);
 434
 435   my $table      = 'list';
 436   my $condition  = "userid='$userid' and type='$listtype'";
 437
 438   my ($err, $errmsg) = $db->find($table, $condition, '*', 'order by sequence');
 439
 440   my ($email_on_file, $rec);
 441
 442   while ($rec = $db->getnext) {
 443     unless ($rec->{domain}) {
 444       $email_on_file = $rec->{pattern};
 445     } else {
 446       unless ($rec->{pattern}) {
 447         $email_on_file = '@' . $rec->{domain};
 448       } else {
 449         $email_on_file = $rec->{pattern} . '@' . $rec->{domain};
 450       } # if
 451     } # unless
 452
 453     # Escape some special characters
 454     $email_on_file =~ s/\@/\\@/;
 455     $email_on_file =~ s/^\*/.\*/;
 456
 457     # We want to terminate the search string with a "$" iff there's an
 458     # "@" in there. This is because some "email_on_file" may have no
 459     # domain (e.g. "mailer-daemon" with no domain). In that case we
 460     # don't want to terminate the search string with a "$" rather we
 461     # wish to terminate it with an "@". But in the case of say
 462     # "@ti.com" if we don't terminate the search string with "$" then
 463     # "@ti.com" would also match "@tixcom.com"!
 464     my $search_for = $email_on_file =~ /\@/
 465                    ? "$email_on_file\$"
 466                    : !defined $rec->{domain}
 467                    ? "$email_on_file\@"
 468                    : $email_on_file;
 469     if ($sender and $sender =~ /$search_for/i) {
 470       $status = 1;
 471
 472       $rec->{hit_count} //= 0;
 473
 474       RecordHit(
 475         userid    => $userid,
 476         type      => $listtype,
 477         sequence  => $rec->{sequence},
 478         hit_count => $rec->{hit_count} + 1,
 479       ) if $update;
 480
 481       last;
 482     } # if
 483   } # while
 484
 485   return ($status, $rec);
 486 } # CheckOnList2
 487
 488 sub CheckOnList ($$;$) {
 489   # CheckOnList will check to see if the $sender is on the list.  Return 1 if
 490   # found 0 if not.
 491   my ($listtype, $sender, $update) = @_;
 492
 493   $update //= 1;
 494
 495   my $status = 0;
 496   my ($rule, $sequence);
 497
 498   my $table      = 'list';
 499   my $condition  = "userid='$userid' and type='$listtype'";
 500
 501   my ($err, $errmsg) = $db->find($table, $condition, '*', 'order by sequence');
 502
 503   my ($email_on_file, $rec);
 504
 505   while ($rec = $db->getnext) {
 506     unless ($rec->{domain}) {
 507       $email_on_file = $rec->{pattern};
 508     } else {
 509       unless ($rec->{pattern}) {
 510         $email_on_file = '@' . $rec->{domain};
 511       } else {
 512         $email_on_file = $rec->{pattern} . '@' . $rec->{domain};
 513       } # if
 514     } # unless
 515
 516     # Escape some special characters
 517     $email_on_file =~ s/\@/\\@/;
 518     $email_on_file =~ s/^\*/.\*/;
 519
 520     # We want to terminate the search string with a "$" iff there's an
 521     # "@" in there. This is because some "email_on_file" may have no
 522     # domain (e.g. "mailer-daemon" with no domain). In that case we
 523     # don't want to terminate the search string with a "$" rather we
 524     # wish to terminate it with an "@". But in the case of say
 525     # "@ti.com" if we don't terminate the search string with "$" then
 526     # "@ti.com" would also match "@tixcom.com"!
 527     my $search_for = $email_on_file =~ /\@/
 528                    ? "$email_on_file\$"
 529                    : !defined $rec->{domain}
 530                    ? "$email_on_file\@"
 531                    : $email_on_file;
 532     if ($sender and $sender =~ /$search_for/i) {
 533       my $comment = $rec->{comment} ? " - $rec->{comment}" : '';
 534
 535       $rule   = "Matching rule: ($listtype:$rec->{sequence}) \"$email_on_file$comment\"";
 536       $rule  .= " - $rec->{comment}" if $rec->{comment};
 537       $status = 1;
 538
 539       $rec->{hit_count} //= 0;
 540
 541       RecordHit(
 542         userid    => $userid,
 543         type      => $listtype,
 544         sequence  => $rec->{sequence},
 545         hit_count => $rec->{hit_count} + 1,
 546       ) if $update;
 547
 548       last;
 549     } # if
 550   } # while
 551
 552   return ($status, $rule, $rec->{sequence}, $rec->{hit_count});
 553 } # CheckOnList
 554
 555 sub CleanEmail($;$) {
 556   my ($timestamp, $dryrun) = @_;
 557
 558   return _cleanTables 'email', $timestamp, $dryrun;
 559 } # ClearEmail
 560
 561 sub CleanLog($;$) {
 562   my ($timestamp, $dryrun) = @_;
 563
 564   return _cleanTables('log', $timestamp, $dryrun);
 565 } # CleanLog
 566
 567 sub CleanList(%) {
 568   my (%params) = @_;
 569
 570   CheckParms(['userid', 'type'], \%params);
 571
 572   my $dryrunstr = $params{dryrun} ? '(dryrun)' : '';
 573
 574   my $table     = 'list';
 575   my $condition = "userid='$params{userid}' and type='$params{type}'";
 576   my $count     = 0;
 577   my $msg;
 578
 579   # First let's go through the list to see if we have an domain level entry
 580   # (e.g. @spammer.com) and also individual entries (baddude@spammer.com) then
 581   # we don't really need any of the individual entries since the domain block
 582   # covers them.
 583   $db->find($table, $condition, ['domain'], ' and pattern is null');
 584
 585   while (my $domains = $db->getnext) {
 586     for my $recs ($db->get($table, $condition, ['sequence', 'pattern', 'domain'],
 587                       " and domain='$domains->{domain}' and pattern is not null")) {
 588       if (@$recs and not $params{dryrun}) {
 589         for my $rec (@$recs) {
 590           DeleteList(
 591             userid   => $params{userid},
 592             type     => $params{type},
 593             sequence => $rec->{sequence},
 594           );
 595
 596           $params{log}->msg("Deleted $params{userid}:$params{type}:$rec->{sequence} "
 597                             .  "$rec->{pattern}\@$rec->{domain} $dryrunstr")
 598             if $params{log};
 599
 600           $count++;
 601         } # for
 602       } elsif (@$recs) {
 603         if ($params{log}) {
 604           $params{log}->msg("The domain $domains->{domain} has the following subrecords");
 605
 606           for my $rec (@$recs) {
 607             $params{log}->msg("$rec->{pattern}\@$rec->{domain}");
 608           } # for
 609         } # if
 610       } # if
 611     } # for
 612   } # while
 613
 614   $condition = "userid='$params{userid}' and type='$params{type}' and retention is not null";
 615
 616   # First see if anything needs to be deleted
 617   ($count, $msg) = $db->count($table, $condition);
 618
 619   return 0 unless $count;
 620
 621   $count = 0;
 622
 623   my ($err, $errmsg) = $db->find($table, $condition);
 624
 625   croak "Unable to find $params{type} entries for $condition - $errmsg" if $err;
 626
 627   my $todaysDate = Today2SQLDatetime;
 628
 629   while (my $rec = $db->getnext) {
 630     my $days = _retention2Days($rec->{retention});
 631
 632     my $agedDate = SubtractDays($todaysDate, $days);
 633
 634     # If last_hit < retentiondays then delete
 635     if (Compare($rec->{last_hit}, $agedDate) == -1) {
 636       unless ($params{dryrun}) {
 637         DeleteList(
 638           userid   => $params{userid},
 639           type     => $params{type},
 640           sequence => $rec->{sequence},
 641         );
 642
 643         if ($params{log}) {
 644           $rec->{pattern} //= '';
 645           $rec->{domain}  //= '';
 646
 647           $params{log}->msg("Deleted $rec->{userid}:$params{type}:$rec->{sequence} "
 648                                   .  "$rec->{pattern}\@$rec->{domain} $dryrunstr");
 649           $params{log}->dbug("last hit = $rec->{last_hit} < agedDate = $agedDate");
 650         } # if
 651       } # unless
 652
 653       $count++;
 654     } else {
 655       $params{log}->dbug("$rec->{userid}:$params{type}:$rec->{sequence}: nodelete $dryrunstr "
 656                        . "last hit = $rec->{last_hit} >= agedDate = $agedDate")
 657         if $params{log};
 658     } # if
 659   } # while
 660
 661   ResequenceList(
 662     userid => $params{userid},
 663     type   => $params{type},
 664   ) if $count && !$params{dryrun};
 665
 666   return $count;
 667 } # CleanList
 668
 669 sub CountEmail(%) {
 670   my (%params) = @_;
 671
 672   CheckParms(['userid'], \%params);
 673
 674   my $table      = 'email';
 675   my $condition  = "userid='$params{userid}'";
 676      $condition .= " and $params{additional}" if $params{additional};
 677
 678   return $db->count($table, $condition);
 679 } # CountEmail
 680
 681 sub CountList(%) {
 682   my (%params) = @_;
 683
 684   CheckParms(['userid', 'type'], \%params);
 685
 686   my $table     = 'list';
 687   my $condition = "userid='$params{userid}' and type='$params{type}'";
 688
 689   return $db->count($table, $condition);
 690 } # CountList
 691
 692 sub CountLog(%) {
 693   my (%params) = @_;
 694
 695   CheckParms(['userid'], \%params);
 696
 697   my ($additional_condition) = delete $params{additional} || '';
 698
 699   my $condition  = "userid='$userid'";
 700      $condition .= " and $additional_condition" if $additional_condition;
 701
 702   return $db->count('log', $condition);
 703 } # CountLog
 704
 705 sub CountLogDistinct(%) {
 706   my (%params) = @_;
 707
 708   CheckParms(['userid', 'column'], \%params);
 709
 710   my ($additional_condition) = delete $params{additional} || '';
 711
 712   my $condition  = "userid='$userid'";
 713      $condition .= " and $additional_condition" if $additional_condition;
 714
 715   return $db->count_distinct('log', $params{column}, $condition);
 716 } # CountLog
 717
 718 sub Decrypt ($$) {
 719   my ($password, $userid) = @_;
 720
 721   return $db->decode($password, $userid);
 722 } # Decrypt
 723
 724 sub DeleteEmail(%) {
 725   my (%rec) = @_;
 726
 727   my $table = 'email';
 728
 729   CheckParms(['userid', 'sender'], \%rec);
 730
 731   my ($username, $domain) = split /@/, $rec{sender};
 732   my $condition;
 733
 734   if ($username) {
 735     $condition = "userid = '$rec{userid}' and sender = '$rec{sender}'";
 736   } else {
 737     $condition = "userid = '$rec{userid}' and sender like '%\@$domain'";
 738   } # if
 739
 740   return $db->delete($table, $condition);
 741 } # DeleteEmail
 742
 743 sub DeleteList(%) {
 744   my (%rec) = @_;
 745
 746   CheckParms(['userid', 'type', 'sequence'], \%rec);
 747
 748   my $condition = "userid = '$rec{userid}' and "
 749                 . "type = '$rec{type}' and "
 750                 . "sequence = $rec{sequence}";
 751
 752   return $db->delete('list', $condition);
 753 } # DeleteList
 754
 755 sub Encrypt($$) {
 756   my ($password, $userid) = @_;
 757
 758   return $db->encode($password, $userid);
 759 } # Encrypt
 760
 761 sub FindEmail(%) {
 762   my (%params) = @_;
 763
 764   CheckParms(['userid'], \%params);
 765
 766   my $table      = 'email';
 767   my $condition  = "userid='$params{userid}'";
 768      $condition .= " and sender='$params{sender}'"       if $params{sender};
 769      $condition .= " and timestamp='$params{timestamp}'" if $params{timestamp};
 770
 771   return $db->find($table, $condition);
 772 } # FindEmail
 773
 774 sub FindList(%) {
 775   my (%params) = @_;
 776
 777   my ($type, $sender) = @_;
 778
 779   CheckParms(['userid', 'type'], \%params);
 780
 781   my $table     = 'list';
 782   my $condition = "userid='$params{userid}' and type='$params{type}'";
 783
 784   if ($params{sender}) {
 785     my ($username, $domain) = split /\@/, $params{sender};
 786
 787     # Split will return '' if either username or domain is missing. This messes
 788     # up SQL's find as '' ~= NULL. Therefore we only specify username or domain
 789     # if it is present.
 790     $condition .= " and pattern='$username'" if $username;
 791     $condition .= " and domain='$domain'"    if $domain;
 792   } # if
 793
 794   return $db->find($table, $condition);
 795 } # FindList
 796
 797 sub FindLog($) {
 798   my ($how_many) = @_;
 799
 800   my $start_at = 0;
 801   my $end_at   = CountLog(
 802     userid => $userid,
 803   );
 804
 805   if ($how_many < 0) {
 806     $start_at = $end_at - abs ($how_many);
 807     $start_at = 0 if ($start_at < 0);
 808   } # if
 809
 810   my $table      = 'log';
 811   my $condition  = "userid='$userid'";
 812   my $additional = "order by timestamp limit $start_at, $end_at";
 813
 814   return $db->find($table, $condition, '*', $additional);
 815 } # FindLog
 816
 817 sub FindUser(%) {
 818   my (%params) = @_;
 819
 820   my $table     = 'user';
 821   my $condition = '';
 822
 823   $condition = "userid='$userid'" if $params{userid};
 824
 825   return $db->find($table, $condition, $params{fields});
 826 } # FindUser
 827
 828 sub FindUsers() {
 829   return $db->find('user', '', ['userid']);
 830 } # FindUsers
 831
 832 sub GetEmail() {
 833   goto &_getnext;
 834 } # GetEmail
 835
 836 sub GetContext() {
 837   return $userid;
 838 } # GetContext
 839
 840 sub GetList() {
 841   goto &_getnext;
 842 } # GetList
 843
 844 sub GetLog() {
 845   goto &_getnext;
 846 } # GetLog
 847
 848 sub GetNextSequenceNo(%) {
 849   my (%rec) = @_;
 850
 851   CheckParms(['userid', 'type'], \%rec);
 852
 853   my $table     = 'list';
 854   my $condition = "userid='$rec{userid}' and type='$rec{type}'";
 855
 856   my $count = $db->count('list', $condition);
 857
 858   return $count + 1;
 859 } # GetNextSequenceNo
 860
 861 sub GetUser() {
 862   goto &_getnext;
 863 } # GetUser
 864
 865 sub GetUserInfo($) {
 866   my ($userid) = @_;
 867
 868   return %{$db->getone('user', "userid='$userid'", ['name', 'email'])};
 869 } # GetUserInfo
 870
 871 sub GetUserOptions($) {
 872   my ($userid) = @_;
 873
 874   my $table     = 'useropts';
 875   my $condition = "userid='$userid'";
 876
 877   $db->find($table, $condition);
 878
 879   my %useropts;
 880
 881   while (my $rec = $db->getnext) {
 882     $useropts{$rec->{name}} = $rec->{value};
 883   } # while
 884
 885   return %useropts;
 886 } # GetUserOptions
 887
 888 sub Login($$) {
 889   my ($userid, $password) = @_;
 890
 891   $password = Encrypt($password, $userid);
 892
 893   # Check if user exists
 894   my $dbpassword = UserExists($userid);
 895
 896   # Return -1 if user doesn't exist
 897   return -1 unless $dbpassword;
 898
 899   # Return -2 if password does not match
 900   if ($password eq $dbpassword) {
 901     SetContext($userid);
 902     return 0
 903   } else {
 904     return -2
 905   } # if
 906 } # Login
 907
 908 sub Nulllist($;$$) {
 909   # Nulllist will simply discard the message.
 910   my ($sender, $sequence, $hit_count) = @_;
 911
 912   RecordHit(
 913     userid    => $userid,
 914     type      => 'null',
 915     sequence  => $sequence,
 916     hit_count => ++$hit_count,
 917   ) if $sequence;
 918
 919   # Discard Message
 920   Logmsg(
 921     userid  => $userid,
 922     type    => 'nulllist',
 923     sender  => $sender,
 924     message => 'Discarded message'
 925   );
 926
 927   return;
 928 } # Nulllist
 929
 930 sub OnBlacklist($;$) {
 931   my ($sender, $update) = @_;
 932
 933   return CheckOnList2('black', $sender, $update);
 934 } # OnBlacklist
 935
 936 sub OnNulllist($;$) {
 937   my ($sender, $update) = @_;
 938
 939   return CheckOnList2('null', $sender, $update);
 940 } # CheckOnNulllist
 941
 942 sub OnWhitelist($;$$) {
 943   my ($sender, $userid, $update) = @_;
 944
 945   SetContext($userid) if $userid;
 946
 947   return CheckOnList2('white', $sender, $update);
 948 } # OnWhitelist
 949
 950 sub OptimizeDB() {
 951   my @tables = qw(email list log user useropts);
 952
 953   my ($err, $msg) = $db->lock('read', \@tables);
 954
 955   croak "Unable to lock table - $msg" if $err;
 956
 957   ($err, $msg) = $db->check(\@tables);
 958
 959   croak 'Unable to check tables ' . $msg if $err;
 960
 961   ($err, $msg) = $db->optimize(\@tables);
 962
 963   croak 'Unable to optimize tables ' . $msg if $err;
 964
 965   return $db->unlock();
 966 } # OptimizeDB
 967
 968 sub ReadMsg($) {
 969   # Reads an email message file from $input. Returns sender, subject,
 970   # date and data, which is a copy of the entire message.
 971   my ($input) = @_;
 972
 973   my $sender          = '';
 974   my $sender_long     = '';
 975   my $envelope_sender = '';
 976   my $reply_to        = '';
 977   my $subject         = '';
 978   my $data            = '';
 979   my @data;
 980
 981   # Find first message's "From " line indicating start of message
 982   while (<$input>) {
 983     chomp;
 984     last if /^From /;
 985   } # while
 986
 987   # If we hit eof here then the message was garbled. Return indication of this
 988   if (eof($input)) {
 989     $data = "Garbled message - unable to find From line";
 990     return $sender, $sender_long, $reply_to, $subject, $data;
 991   } # if
 992
 993   if (/From (\S*)/) {
 994     $envelope_sender = $1;
 995     $sender_long     = $envelope_sender;
 996   } # if
 997
 998   push @data, $_ if /^From /;
 999
1000   while (<$input>) {
1001     chomp;
1002     push @data, $_;
1003
1004     # Blank line indicates start of message body
1005     last if ($_ eq "" || $_ eq "\r");
1006
1007     # Extract sender's address
1008     if (/^from: .*/i) {
1009       $_ = substr ($_, 6);
1010
1011       $sender_long = $_;
1012
1013       if (/<(\S*)@(\S*)>/) {
1014         $sender = lc ("$1\@$2");
1015       } elsif (/(\S*)@(\S*)\ /) {
1016         $sender = lc ("$1\@$2");
1017       } elsif (/(\S*)@(\S*)/) {
1018         $sender = lc ("$1\@$2");
1019       } # if
1020     } elsif (/^subject: .*/i) {
1021       $subject = substr ($_, 9);
1022     } elsif (/^reply-to: .*/i) {
1023       $_ = substr ($_, 10);
1024       if (/<(\S*)@(\S*)>/) {
1025         $reply_to = lc ("$1\@$2");
1026       } elsif (/(\S*)@(\S*)\ /) {
1027         $reply_to = lc ("$1\@$2");
1028       } elsif (/(\S*)@(\S*)/) {
1029         $reply_to = lc ("$1\@$2");
1030       } # if
1031     } # if
1032   } # while
1033
1034   # Read message body
1035   while (<$input>) {
1036     chomp;
1037
1038     last if (/^From /);
1039     push @data, $_;
1040   } # while
1041
1042   # Set file pointer back by length of the line just read
1043   seek ($input, -length () - 1, 1) if !eof $input;
1044
1045   # Sanitize email addresses
1046   $envelope_sender =~ s/\<//g;
1047   $envelope_sender =~ s/\>//g;
1048   $envelope_sender =~ s/\"//g;
1049   $envelope_sender =~ s/\'//g;
1050   $sender          =~ s/\<//g;
1051   $sender          =~ s/\>//g;
1052   $sender          =~ s/\"//g;
1053   $sender          =~ s/\'//g;
1054   $reply_to        =~ s/\<//g;
1055   $reply_to        =~ s/\>//g;
1056   $reply_to        =~ s/\"//g;
1057   $reply_to        =~ s/\'//g;
1058
1059   # Determine best addresses
1060   $sender    = $envelope_sender if $sender eq "";
1061   $reply_to  = $sender          if $reply_to eq "";
1062
1063   return $sender, $sender_long, $reply_to, $subject, join "\n", @data;
1064 } # ReadMsg
1065
1066 sub RecordHit(%) {
1067   my (%rec) = @_;
1068
1069   CheckParms(['userid', 'type', 'sequence', ], \%rec);
1070
1071   my $current_date = UnixDatetime2SQLDatetime(scalar(localtime));
1072
1073   my $table     = 'list';
1074   my $condition = "userid='$rec{userid}' and type='$rec{type}' and sequence='$rec{sequence}'";
1075
1076   return $db->modify($table, $condition, %rec);
1077 } # RecordHit
1078
1079 sub ResequenceList(%) {
1080   my (%params) = @_;
1081
1082   CheckParms(['userid', 'type'], \%params);
1083
1084   # Data checks
1085   return 1 unless $params{type} =~ /(white|black|null)/;
1086   return 2 unless UserExists($params{userid});
1087
1088   my $table     = 'list';
1089   my $condition = "userid='$params{userid}' and type ='$params{type}'";
1090
1091   # Lock the table
1092   $db->lock('write', $table);
1093
1094   # Get all records for $userid and $type
1095   my $listrecs = $db->get($table, $condition,'*', 'order by hit_count desc');
1096
1097   # Delete all of the list entries for this $userid and $type
1098   my ($count, $msg) = $db->delete($table, $condition);
1099
1100   # Now re-add list entries renumbering them
1101   my $sequence = 1;
1102
1103   for (@$listrecs) {
1104     $_->{sequence} = $sequence++;
1105
1106     my ($err, $msg) = $db->add($table, %$_);
1107
1108     croak $msg if $err;
1109   } # for
1110
1111   $db->unlock;
1112
1113   return 0;
1114 } # ResequenceList
1115
1116 sub ReturnList(%) {
1117   my (%params) = @_;
1118
1119   CheckParms(['userid', 'type'], \%params);
1120
1121   my $start_at = delete $params{start_at} || 0;
1122   my $lines    = delete $params{lines}    || 10;
1123
1124   my $table      = 'list';
1125   my $condition  = "userid='$params{userid}' and type='$params{type}'";
1126   my $additional = "order by sequence limit $start_at, $lines";
1127
1128   return $db->get($table, $condition, '*', $additional);
1129 } # ReturnList
1130
1131 sub ReturnMsg(%) {
1132   my (%params) = @_;
1133
1134   # ReturnMsg will send back to the $sender the register message.
1135   # Messages are saved to be delivered when the $sender registers.
1136   #
1137   # Added reply_to. Previously we passed reply_to into here as sender. This
1138   # caused a problem in that we were filtering as per sender but logging it
1139   # as reply_to. We only need reply_to for SendMsg so as to honor reply_to
1140   # so we now pass in both sender and reply_to
1141
1142   CheckParms(['userid', 'sender', 'reply_to', 'subject', 'data'], \%params);
1143
1144   #my ($sender, $reply_to, $subject, $data) = @_;
1145
1146   # Check to see if this sender has already emailed us.
1147   my $msg_count = $db->count('email', "userid='$userid' and sender like '%$params{sender}%'");
1148
1149   if ($msg_count < 5) {
1150     # Return register message
1151     SendMsg(
1152       userid   => $params{userid},
1153       sender   => $params{reply_to},
1154       subject  => 'Your email has been returned by MAPS',
1155       msgfile  => "$mapsbase/register.html",
1156       data     => $params{data},
1157     ) if $msg_count == 0;
1158
1159     Logmsg(
1160       userid  => $params{userid},
1161       type    => 'returned',
1162       sender  => $params{sender},
1163       message => 'Sent register reply',
1164     );
1165
1166     # Save message
1167     SaveMsg($params{sender}, $params{subject}, $params{data});
1168   } else {
1169     Add2Nulllist($params{sender}, GetContext, "Auto Null List - Mail loop");
1170
1171     Logmsg(
1172       userid  => $params{userid},
1173       type    => 'mailloop',
1174       sender  => $params{sender},
1175       message => 'Mail loop encountered',
1176     );
1177   } # if
1178
1179   return;
1180 } # ReturnMsg
1181
1182 sub ReturnMessages(%) {
1183   my (%params) = @_;
1184
1185   CheckParms(['userid', 'sender'], \%params);
1186
1187   my $table      = 'email';
1188   my $condition  = "userid='$params{userid}' and sender='$params{sender}'";
1189   my $fields     = ['subject', 'timestamp'];
1190   my $additional = 'group by timestamp desc';
1191
1192   return $db->get($table, $condition, $fields, $additional);
1193 } # ReturnMessages
1194
1195 sub ReturnSenders(%) {
1196   my (%params) = @_;
1197   # This subroutine returns an array of senders in reverse chronological
1198   # order based on time timestamp from the log table of when we returned
1199   # their message. The complication here is that a single sender may
1200   # send multiple times in a single day. So if spammer@foo.com sends
1201   # spam @ 1 second after midnight and then again at 2 Pm there will be
1202   # at least two records in the log table saying that we returned his
1203   # email. Getting records sorted by timestamp desc will have
1204   # spammer@foo.com listed twice. But we want him listed only once, as
1205   # the first entry in the returned array. Plus we may be called
1206   # repeatedly with different $start_at's. Therefore we need to process
1207   # the whole list of returns for today, eliminate duplicate entries for
1208   # a single sender then slice the resulting array.
1209   CheckParms(['userid', 'type', 'lines'], \%params);
1210
1211   my $table      = 'log';
1212   my $condition  = "userid='$params{userid}' and type='$params{type}'";
1213   my $additional = 'order by timestamp desc';
1214
1215   $params{start_at} ||= 0;
1216
1217   if ($params{date}) {
1218     $condition .= "and timestamp > '$params{date} 00:00:00' and "
1219                .      "timestamp < '$params{date} 23:59:59'";
1220   } # if
1221
1222   $db->find($table, $condition, '*', $additional);
1223
1224   # Watch the distinction between senders (plural) and sender (singular)
1225   my %senders;
1226
1227   # Run through the results and add to %senders by sender key. This
1228   # results in a hash that has the sender in it and the first
1229   # timestamp value. Since we already sorted timestamp desc by the
1230   # above select statement, and we've narrowed it down to only log
1231   # message that occurred for the given $date, we will have a hash
1232   # containing 1 sender and the latest timestamp for the day.
1233   while (my $rec = $db->getnext) {
1234     $senders{$rec->{sender}} = $rec->{timestamp}
1235       unless $senders{$rec->{sender}};
1236   } # while
1237
1238   my (@unsorted, @senders);
1239
1240   # Here we have a hash in %senders that has email address and timestamp. In the
1241   # past we would merely create a reverse hash by timestamp and sort that. The
1242   # The problem is that it is possible for two emails to come in with the same
1243   # timestamp. By reversing the hash we clobber any row that has a dumplicte
1244   # timestamp. But we want to sort on timestamp. So first we convers this hash
1245   # to an array of hashes and then we can sort by timestamp later.
1246   while (my ($key, $value) = each %senders) {
1247     push @unsorted, {
1248       sender    => $key,
1249       timestamp => $value,
1250     };
1251   } # while
1252
1253   push @senders, $_->{sender} for sort { $b->{timestamp} cmp $a->{timestamp}} @unsorted;
1254
1255   # Finally slice for the given range
1256   my $end_at = $params{start_at} + ($params{lines} - 1);
1257
1258   $end_at = (@senders) - 1 if $end_at >= @senders;
1259
1260   return (@senders) [$params{start_at} .. $end_at];
1261 } # ReturnSenders
1262
1263 sub SaveMsg($$$) {
1264   my ($sender, $subject, $data) = @_;
1265
1266   AddEmail(
1267     userid  => $userid,
1268     sender  => $sender,
1269     subject => $subject,
1270     data    => $data,
1271   );
1272
1273   return;
1274 } # SaveMsg
1275
1276 sub SearchEmails(%) {
1277   my (%params) = @_;
1278
1279   CheckParms(['userid', 'search'], \%params);
1280
1281   my $table      = 'email';
1282   my $fields     = ['sender', 'subject', 'timestamp'];
1283   my $condition  = "userid='$params{userid}' and (sender like '\%$params{search}\%' "
1284                  . "or subject like '\%$params{search}\%')";
1285   my $additional = 'order by timestamp desc';
1286
1287   my ($err, $msg) = $db->find($table, $condition, $fields, $additional);
1288
1289   my @emails;
1290
1291   while (my $rec = $db->getnext) {
1292     push @emails, $rec;
1293   } # while
1294
1295   return @emails;
1296 } # SearchEmails
1297
1298 sub SendMsg(%) {
1299   # SendMsg will send the message contained in $msgfile.
1300   my (%params) = @_;
1301
1302   #my ($sender, $subject, $msgfile, $userid, @spammsg) = @_;
1303
1304   my @lines;
1305
1306   # Open return message template file
1307   open my $return_msg_file, '<', $params{msgfile}
1308     or die "Unable to open return msg file ($params{msgfile}): $!\n";
1309
1310   # Read return message template file and print it to $msg_body
1311   while (<$return_msg_file>) {
1312     if (/\$userid/) {
1313       # Replace userid
1314       s/\$userid/$userid/;
1315     } # if
1316     if (/\$sender/) {
1317       # Replace sender
1318       s/\$sender/$params{sender}/;
1319     } #if
1320
1321     push @lines, $_;
1322   } # while
1323
1324   close $return_msg_file;
1325
1326   # Create the message, and set up the mail headers:
1327   my $msg = MIME::Entity->build(
1328     From    => "MAPS\@DeFaria.com",
1329     To      => $params{sender},
1330     Subject => $params{subject},
1331     Type    => "text/html",
1332     Data    => \@lines
1333   );
1334
1335   # Need to obtain the spam message here...
1336   my @spammsg = split "\n", $params{data};
1337
1338   $msg->attach(
1339     Type        => "message",
1340     Disposition => "attachment",
1341     Data        => \@spammsg
1342   );
1343
1344   # Send it
1345   open my $mail, '|-', '/usr/lib/sendmail -t -oi -oem'
1346     or croak "SendMsg: Unable to open pipe to sendmail $!";
1347
1348   $msg->print(\*$mail);
1349
1350   close $mail;
1351
1352   return;
1353 } # SendMsg
1354
1355 sub SetContext($) {
1356   my ($to_user) = @_;
1357
1358   if (UserExists($to_user)) {
1359     $userid = $to_user;
1360
1361     return GetUserOptions $userid;
1362   } else {
1363     return 0;
1364   } # if
1365 } # SetContext
1366
1367 sub Space($) {
1368   my ($userid) = @_;
1369
1370   my $total_space = 0;
1371   my $table       = 'email';
1372   my $condition   = "userid='$userid'";
1373
1374   $db->find($table, $condition);
1375
1376   while (my $rec = $db->getnext) {
1377     $total_space +=
1378       length($rec->{userid})    +
1379       length($rec->{sender})    +
1380       length($rec->{subject})   +
1381       length($rec->{timestamp}) +
1382       length($rec->{data});
1383   } # while
1384
1385   return $total_space;
1386 } # Space
1387
1388 sub UpdateList(%) {
1389   my (%rec) = @_;
1390
1391   CheckParms(['userid', 'type', 'sequence'], \%rec);
1392
1393   my $table     = 'list';
1394   my $condition = "userid = '$rec{userid}' and type = '$rec{type}' and sequence = $rec{sequence}";
1395
1396   if ($rec{pattern} =~ /\@/ && !$rec{domain}) {
1397     ($rec{pattern}, $rec{domain}) = split /\@/, $rec{pattern};
1398   } elsif (!$rec{pattern} && $rec{domain} =~ /\@/) {
1399     ($rec{pattern}, $rec{domain}) = split /\@/, $rec{domain};
1400   } elsif (!$rec{pattern} && !$rec{domain}) {
1401     return "Must specify either Username or Domain";
1402   } # if
1403
1404   $rec{pattern}   //= 'null';
1405   $rec{domain}    //= 'null';
1406   $rec{comment}   //= 'null';
1407
1408   if ($rec{retention}) {
1409     $rec{retention} = lc $rec{retention};
1410   } # if
1411
1412   return $db->update($table, $condition, %rec);
1413 } # UpdateList
1414
1415 sub UpdateUser(%) {
1416   my (%rec) = @_;
1417
1418   CheckParms(['userid', 'name', 'email'], \%rec);
1419
1420   return 1 unless UserExists($rec{userid});
1421
1422   my $table = 'user';
1423   my $condition = "userid='$rec{userid}'";
1424
1425   return $db->update($table, $condition, %rec);
1426 } # UpdateUser
1427
1428 sub UpdateUserOptions ($@) {
1429   my ($userid, %options)  = @_;
1430
1431   return unless UserExists($userid);
1432
1433   my $table     = 'useropts';
1434   my $condition = "userid='$userid' and name=";
1435
1436   $db->update($table, "$condition'$_'", (name=>$_, value=>$options{$_})) for (keys %options);
1437
1438   return;
1439 } # UpdateUserOptions
1440
1441 sub UserExists($) {
1442   my ($userid) = @_;
1443
1444   return 0 unless $userid;
1445
1446   my $table     = 'user';
1447   my $condition = "userid='$userid'";
1448
1449   my $rec = $db->get($table, $condition);
1450
1451   return 0 if scalar(@$rec) == 0;
1452
1453   return $rec->[0]{password};
1454 } # UserExists
1455
1456 sub Whitelist ($$;$$) {
1457   # Whitelist will deliver the message.
1458   my ($sender, $data, $sequence, $hit_count) = @_;
1459
1460   my $userid = GetContext;
1461
1462   # Dump message into a file
1463   open my $message, '>', "/tmp/MAPSMessage.$$"
1464     or Error("Unable to open message file (/tmp/MAPSMessage.$$): $!\n"), return -1;
1465
1466   print $message $data;
1467
1468   close $message;
1469
1470   # Now call MAPSDeliver
1471   my $status = system "$FindBin::Bin/MAPSDeliver $userid /tmp/MAPSMessage.$$";
1472
1473   unlink "/tmp/MAPSMessage.$$";
1474
1475   if ($status == 0) {
1476     Logmsg(
1477       userid  => $userid,
1478       type    => 'whitelist',
1479       sender  => $sender,
1480       message => 'Delivered message',
1481     );
1482   } else {
1483     Error("Unable to deliver message - is MAPSDeliver setgid? - $!");
1484   } # if
1485
1486   $hit_count++ if $sequence;
1487
1488   RecordHit(
1489     userid   => $userid,
1490     type     => 'white',
1491     sequence => $sequence,
1492     hit_count => $hit_count,
1493   );
1494
1495   return $status;
1496 } # Whitelist
1497
1498 1;