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