maps/lib/MAPS.pm

   1 ################################################################################
   2 #
   3 # File:         $RCSfile: MAPS.pm,v $
   4 # Revision:     $Revision: 1.1 $
   5 # Description:  Main module for Mail Authentication and Permission System (MAPS)
   6 # Author:       Andrew@DeFaria.com
   7 # Created:      Fri Nov 29 14:17:21  2002
   8 # Modified:     $Date: 2013/06/12 14:05:47 $
   9 # Language:     perl
  10 #
  11 # (c) Copyright 2000-2018, Andrew@DeFaria.com, all rights reserved.
  12 #
  13 ################################################################################
  14 package MAPS;
  15
  16 use strict;
  17 use warnings;
  18
  19 use DBI;
  20 use Carp;
  21 use FindBin;
  22 use Exporter;
  23
  24 use MAPSLog;
  25 use MIME::Entity;
  26
  27 use Display;
  28 use MyDB;
  29 use Utils;
  30 use DateUtils;
  31
  32 use base qw(Exporter);
  33
  34 our $db;
  35
  36 our $VERSION = '2.0';
  37
  38 # Globals
  39 my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
  40 my %useropts;
  41 my $mailLoopMax = 5;
  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 < $mailLoopMax) {
 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   my ($input) = @_;
 970
 971   my (%msgInfo, @data, $envelope_sender);
 972
 973   # Reads an email message file from $input. Returns sender, subject, date and
 974   # data, which is a copy of the entire message. Find first message's "From "
 975   # line indicating start of message.
 976   while (<$input>) {
 977     chomp;
 978     last if /^From /;
 979   } # while
 980
 981   # If we hit eof here then the message was garbled. Return indication of this
 982   return if eof($input);
 983
 984   if (/From (\S*)/) {
 985     $msgInfo{sender_long} = $envelope_sender = $1;
 986   } # if
 987
 988   push @data, $_ if /^From /;
 989
 990   while (<$input>) {
 991     chomp; chop if /\r$/;
 992
 993     push @data, $_;
 994
 995     # Blank line indicates start of message body
 996     last if ($_ eq '' || $_ eq "\r");
 997
 998     # Extract sender's address
 999     if (/^from: (.*)/i) {
1000       $msgInfo{sender_long} = $msgInfo{sender} = $1;
1001
1002       if ($msgInfo{sender} =~ /<(\S*)@(\S*)>/) {
1003         $msgInfo{sender} = lc ("$1\@$2");
1004       } elsif ($msgInfo{sender} =~ /(\S*)@(\S*)\ /) {
1005         $msgInfo{sender} = lc ("$1\@$2");
1006       } elsif ($msgInfo{sender} =~ /(\S*)@(\S*)/) {
1007         $msgInfo{sender} = lc ("$1\@$2");
1008       } # if
1009     } elsif (/^subject: (.*)/i) {
1010       $msgInfo{subject} = $1;
1011     } elsif (/^reply-to: (.*)/i) {
1012       $msgInfo{reply_to} = $1;
1013
1014       if ($msgInfo{reply_to} =~ /<(\S*)@(\S*)>/) {
1015         $msgInfo{reply_to} = lc ("$1\@$2");
1016       } elsif ($msgInfo{reply_to} =~ /(\S*)@(\S*)\ /) {
1017         $msgInfo{reply_to} = lc ("$1\@$2");
1018       } elsif ($msgInfo{reply_to} =~ /(\S*)@(\S*)/) {
1019         $msgInfo{reply_to} = lc ("$1\@$2");
1020       } # if
1021     } elsif (/^to: (.*)/i) {
1022       $msgInfo{to} = $1;
1023
1024       if ($msgInfo{to} =~ /<(\S*)@(\S*)>/) {
1025         $msgInfo{to} = lc ("$1\@$2");
1026       } elsif ($msgInfo{to} =~ /(\S*)@(\S*)\ /) {
1027         $msgInfo{to} = lc ("$1\@$2");
1028       } elsif ($msgInfo{to} =~ /(\S*)@(\S*)/) {
1029         $msgInfo{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
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
1052   $msgInfo{sender}   =~ s/\<//g;
1053   $msgInfo{sender}   =~ s/\>//g;
1054   $msgInfo{sender}   =~ s/\"//g;
1055   $msgInfo{sender}   =~ s/\'//g;
1056
1057   if ($msgInfo{reply_to}) {
1058     $msgInfo{reply_to} =~ s/\<//g;
1059     $msgInfo{reply_to} =~ s/\>//g;
1060     $msgInfo{reply_to} =~ s/\"//g;
1061     $msgInfo{reply_to} =~ s/\'//g;
1062   } # if
1063
1064   # Determine best addresses
1065   $msgInfo{sender}   = $envelope_sender unless $msgInfo{sender};
1066   $msgInfo{reply_to} = $msgInfo{sender} unless $msgInfo{reply_to};
1067
1068   $msgInfo{data} = join "\n", @data;
1069
1070   return %msgInfo;
1071 } # ReadMsg
1072
1073 sub RecordHit(%) {
1074   my (%rec) = @_;
1075
1076   CheckParms(['userid', 'type', 'sequence'], \%rec);
1077
1078   my $table     = 'list';
1079   my $condition = "userid='$rec{userid}' and type='$rec{type}' and sequence='$rec{sequence}'";
1080
1081   # We don't need these fields in %rec as we are not updating them
1082   delete $rec{sequence};
1083   delete $rec{type};
1084   delete $rec{userid};
1085
1086   # We are, however, updating last_hit
1087   $rec{last_hit} = UnixDatetime2SQLDatetime(scalar(localtime));
1088
1089   return $db->modify($table, $condition, %rec);
1090 } # RecordHit
1091
1092 sub ResequenceList(%) {
1093   my (%params) = @_;
1094
1095   CheckParms(['userid', 'type'], \%params);
1096
1097   # Data checks
1098   return 1 unless $params{type} =~ /(white|black|null)/;
1099   return 2 unless UserExists($params{userid});
1100
1101   my $table     = 'list';
1102   my $condition = "userid='$params{userid}' and type ='$params{type}'";
1103
1104   # Lock the table
1105   $db->lock('write', $table);
1106
1107   # Get all records for $userid and $type
1108   my $listrecs = $db->get($table, $condition,'*', 'order by hit_count desc');
1109
1110   # Delete all of the list entries for this $userid and $type
1111   my ($count, $msg) = $db->delete($table, $condition);
1112
1113   # Now re-add list entries renumbering them
1114   my $sequence = 1;
1115
1116   for (@$listrecs) {
1117     $_->{sequence} = $sequence++;
1118
1119     my ($err, $msg) = $db->add($table, %$_);
1120
1121     croak $msg if $err;
1122   } # for
1123
1124   $db->unlock;
1125
1126   return 0;
1127 } # ResequenceList
1128
1129 sub ReturnList(%) {
1130   my (%params) = @_;
1131
1132   CheckParms(['userid', 'type'], \%params);
1133
1134   my $start_at = delete $params{start_at} || 0;
1135   my $lines    = delete $params{lines}    || 10;
1136
1137   my $table      = 'list';
1138   my $condition  = "userid='$params{userid}' and type='$params{type}'";
1139   my $additional = "order by sequence limit $start_at, $lines";
1140
1141   return $db->get($table, $condition, '*', $additional);
1142 } # ReturnList
1143
1144 sub ReturnMsg(%) {
1145   my (%params) = @_;
1146
1147   # ReturnMsg will send back to the $sender the register message.
1148   # Messages are saved to be delivered when the $sender registers.
1149   #
1150   # Added reply_to. Previously we passed reply_to into here as sender. This
1151   # caused a problem in that we were filtering as per sender but logging it
1152   # as reply_to. We only need reply_to for SendMsg so as to honor reply_to
1153   # so we now pass in both sender and reply_to
1154
1155   CheckParms(['userid', 'sender', 'reply_to', 'subject', 'data'], \%params);
1156
1157   #my ($sender, $reply_to, $subject, $data) = @_;
1158
1159   # Check to see if this sender has already emailed us.
1160   my $msg_count = $db->count('email', "userid='$userid' and sender like '%$params{sender}%'");
1161
1162   if ($msg_count < $mailLoopMax) {
1163     # Return register message
1164     SendMsg(
1165       userid   => $params{userid},
1166       sender   => $params{reply_to},
1167       subject  => 'Your email has been returned by MAPS',
1168       msgfile  => "$mapsbase/register.html",
1169       data     => $params{data},
1170     ) if $msg_count == 0;
1171
1172     Logmsg(
1173       userid  => $params{userid},
1174       type    => 'returned',
1175       sender  => $params{sender},
1176       message => 'Sent register reply',
1177     );
1178
1179     # Save message
1180     SaveMsg($params{sender}, $params{subject}, $params{data});
1181   } else {
1182     Add2Nulllist($params{sender}, GetContext, "Auto Null List - Mail loop");
1183
1184     Logmsg(
1185       userid  => $params{userid},
1186       type    => 'mailloop',
1187       sender  => $params{sender},
1188       message => 'Mail loop encountered',
1189     );
1190   } # if
1191
1192   return;
1193 } # ReturnMsg
1194
1195 sub ReturnMessages(%) {
1196   my (%params) = @_;
1197
1198   CheckParms(['userid', 'sender'], \%params);
1199
1200   my $table      = 'email';
1201   my $condition  = "userid='$params{userid}' and sender='$params{sender}'";
1202   my $fields     = ['subject', 'timestamp'];
1203   my $additional = 'group by timestamp desc';
1204
1205   return $db->get($table, $condition, $fields, $additional);
1206 } # ReturnMessages
1207
1208 sub ReturnSenders(%) {
1209   my (%params) = @_;
1210   # This subroutine returns an array of senders in reverse chronological
1211   # order based on time timestamp from the log table of when we returned
1212   # their message. The complication here is that a single sender may
1213   # send multiple times in a single day. So if spammer@foo.com sends
1214   # spam @ 1 second after midnight and then again at 2 Pm there will be
1215   # at least two records in the log table saying that we returned his
1216   # email. Getting records sorted by timestamp desc will have
1217   # spammer@foo.com listed twice. But we want him listed only once, as
1218   # the first entry in the returned array. Plus we may be called
1219   # repeatedly with different $start_at's. Therefore we need to process
1220   # the whole list of returns for today, eliminate duplicate entries for
1221   # a single sender then slice the resulting array.
1222   CheckParms(['userid', 'type', 'lines'], \%params);
1223
1224   my $table      = 'log';
1225   my $condition  = "userid='$params{userid}' and type='$params{type}'";
1226   my $additional = 'order by timestamp desc';
1227
1228   $params{start_at} ||= 0;
1229
1230   if ($params{date}) {
1231     $condition .= "and timestamp > '$params{date} 00:00:00' and "
1232                .      "timestamp < '$params{date} 23:59:59'";
1233   } # if
1234
1235   $db->find($table, $condition, '*', $additional);
1236
1237   # Watch the distinction between senders (plural) and sender (singular)
1238   my %senders;
1239
1240   # Run through the results and add to %senders by sender key. This
1241   # results in a hash that has the sender in it and the first
1242   # timestamp value. Since we already sorted timestamp desc by the
1243   # above select statement, and we've narrowed it down to only log
1244   # message that occurred for the given $date, we will have a hash
1245   # containing 1 sender and the latest timestamp for the day.
1246   while (my $rec = $db->getnext) {
1247     $senders{$rec->{sender}} = $rec->{timestamp}
1248       unless $senders{$rec->{sender}};
1249   } # while
1250
1251   my (@unsorted, @senders);
1252
1253   # Here we have a hash in %senders that has email address and timestamp. In the
1254   # past we would merely create a reverse hash by timestamp and sort that. The
1255   # The problem is that it is possible for two emails to come in with the same
1256   # timestamp. By reversing the hash we clobber any row that has a dumplicte
1257   # timestamp. But we want to sort on timestamp. So first we convers this hash
1258   # to an array of hashes and then we can sort by timestamp later.
1259   while (my ($key, $value) = each %senders) {
1260     push @unsorted, {
1261       sender    => $key,
1262       timestamp => $value,
1263     };
1264   } # while
1265
1266   push @senders, $_->{sender} for sort { $b->{timestamp} cmp $a->{timestamp}} @unsorted;
1267
1268   # Finally slice for the given range
1269   my $end_at = $params{start_at} + ($params{lines} - 1);
1270
1271   $end_at = (@senders) - 1 if $end_at >= @senders;
1272
1273   return (@senders) [$params{start_at} .. $end_at];
1274 } # ReturnSenders
1275
1276 sub SaveMsg($$$) {
1277   my ($sender, $subject, $data) = @_;
1278
1279   AddEmail(
1280     userid  => $userid,
1281     sender  => $sender,
1282     subject => $subject,
1283     data    => $data,
1284   );
1285
1286   return;
1287 } # SaveMsg
1288
1289 sub SearchEmails(%) {
1290   my (%params) = @_;
1291
1292   CheckParms(['userid', 'search'], \%params);
1293
1294   my $table      = 'email';
1295   my $fields     = ['sender', 'subject', 'timestamp'];
1296   my $condition  = "userid='$params{userid}' and (sender like '\%$params{search}\%' "
1297                  . "or subject like '\%$params{search}\%')";
1298   my $additional = 'order by timestamp desc';
1299
1300   my ($err, $msg) = $db->find($table, $condition, $fields, $additional);
1301
1302   my @emails;
1303
1304   while (my $rec = $db->getnext) {
1305     push @emails, $rec;
1306   } # while
1307
1308   return @emails;
1309 } # SearchEmails
1310
1311 sub SendMsg(%) {
1312   # SendMsg will send the message contained in $msgfile.
1313   my (%params) = @_;
1314
1315   #my ($sender, $subject, $msgfile, $userid, @spammsg) = @_;
1316
1317   my @lines;
1318
1319   # Open return message template file
1320   open my $return_msg_file, '<', $params{msgfile}
1321     or die "Unable to open return msg file ($params{msgfile}): $!\n";
1322
1323   # Read return message template file and print it to $msg_body
1324   while (<$return_msg_file>) {
1325     if (/\$userid/) {
1326       # Replace userid
1327       s/\$userid/$userid/;
1328     } # if
1329     if (/\$sender/) {
1330       # Replace sender
1331       s/\$sender/$params{sender}/;
1332     } #if
1333
1334     push @lines, $_;
1335   } # while
1336
1337   close $return_msg_file;
1338
1339   # Create the message, and set up the mail headers:
1340   my $msg = MIME::Entity->build(
1341     From    => "MAPS\@DeFaria.com",
1342     To      => $params{sender},
1343     Subject => $params{subject},
1344     Type    => "text/html",
1345     Data    => \@lines
1346   );
1347
1348   # Need to obtain the spam message here...
1349   my @spammsg = split "\n", $params{data};
1350
1351   $msg->attach(
1352     Type        => "message",
1353     Disposition => "attachment",
1354     Data        => \@spammsg
1355   );
1356
1357   # Send it
1358   open my $mail, '|-', '/usr/lib/sendmail -t -oi -oem'
1359     or croak "SendMsg: Unable to open pipe to sendmail $!";
1360
1361   $msg->print(\*$mail);
1362
1363   close $mail;
1364
1365   return;
1366 } # SendMsg
1367
1368 sub SetContext($) {
1369   my ($to_user) = @_;
1370
1371   if (UserExists($to_user)) {
1372     $userid = $to_user;
1373
1374     return GetUserOptions $userid;
1375   } else {
1376     return 0;
1377   } # if
1378 } # SetContext
1379
1380 sub Space($) {
1381   my ($userid) = @_;
1382
1383   my $total_space = 0;
1384   my $table       = 'email';
1385   my $condition   = "userid='$userid'";
1386
1387   $db->find($table, $condition);
1388
1389   while (my $rec = $db->getnext) {
1390     $total_space +=
1391       length($rec->{userid})    +
1392       length($rec->{sender})    +
1393       length($rec->{subject})   +
1394       length($rec->{timestamp}) +
1395       length($rec->{data});
1396   } # while
1397
1398   return $total_space;
1399 } # Space
1400
1401 sub UpdateList(%) {
1402   my (%rec) = @_;
1403
1404   CheckParms(['userid', 'type', 'sequence'], \%rec);
1405
1406   my $table     = 'list';
1407   my $condition = "userid = '$rec{userid}' and type = '$rec{type}' and sequence = $rec{sequence}";
1408
1409   if ($rec{pattern} =~ /\@/ && !$rec{domain}) {
1410     ($rec{pattern}, $rec{domain}) = split /\@/, $rec{pattern};
1411   } elsif (!$rec{pattern} && $rec{domain} =~ /\@/) {
1412     ($rec{pattern}, $rec{domain}) = split /\@/, $rec{domain};
1413   } elsif (!$rec{pattern} && !$rec{domain}) {
1414     return "Must specify either Username or Domain";
1415   } # if
1416
1417   $rec{pattern}   //= 'null';
1418   $rec{domain}    //= 'null';
1419   $rec{comment}   //= 'null';
1420
1421   if ($rec{retention}) {
1422     $rec{retention} = lc $rec{retention};
1423   } # if
1424
1425   return $db->update($table, $condition, %rec);
1426 } # UpdateList
1427
1428 sub UpdateUser(%) {
1429   my (%rec) = @_;
1430
1431   CheckParms(['userid', 'name', 'email'], \%rec);
1432
1433   return 1 unless UserExists($rec{userid});
1434
1435   my $table = 'user';
1436   my $condition = "userid='$rec{userid}'";
1437
1438   return $db->update($table, $condition, %rec);
1439 } # UpdateUser
1440
1441 sub UpdateUserOptions ($@) {
1442   my ($userid, %options)  = @_;
1443
1444   return unless UserExists($userid);
1445
1446   my $table     = 'useropts';
1447   my $condition = "userid='$userid' and name=";
1448
1449   $db->update($table, "$condition'$_'", (name=>$_, value=>$options{$_})) for (keys %options);
1450
1451   return;
1452 } # UpdateUserOptions
1453
1454 sub UserExists($) {
1455   my ($userid) = @_;
1456
1457   return 0 unless $userid;
1458
1459   my $table     = 'user';
1460   my $condition = "userid='$userid'";
1461
1462   my $rec = $db->get($table, $condition);
1463
1464   return 0 if scalar(@$rec) == 0;
1465
1466   return $rec->[0]{password};
1467 } # UserExists
1468
1469 sub Whitelist ($$;$$) {
1470   # Whitelist will deliver the message.
1471   my ($sender, $data, $sequence, $hit_count) = @_;
1472
1473   my $userid = GetContext;
1474
1475   # Dump message into a file
1476   open my $message, '>', "/tmp/MAPSMessage.$$"
1477     or error("Unable to open message file (/tmp/MAPSMessage.$$): $!\n"), return -1;
1478
1479   print $message $data;
1480
1481   close $message;
1482
1483   # Now call MAPSDeliver
1484   my ($status, @output) = Execute "$FindBin::Bin/MAPSDeliver $userid /tmp/MAPSMessage.$$";
1485   #my $status = system "$FindBin::Bin/MAPSDeliver $userid /tmp/MAPSMessage.$$";
1486
1487   if ($status != 0) {
1488     my $msg =  "Unable to deliver message (message left at /tmp/MAPSMessage.%%\n\n";
1489        $msg .= join "\n", @output;
1490
1491     Logmsg(
1492       userid  => $userid,
1493       type    => 'whitelist',
1494       sender  => $sender,
1495       message => $msg,
1496     );
1497
1498     Error ($msg, 1);
1499   } # if
1500
1501   unlink "/tmp/MAPSMessage.$$";
1502
1503   if ($status == 0) {
1504     Logmsg(
1505       userid  => $userid,
1506       type    => 'whitelist',
1507       sender  => $sender,
1508       message => 'Delivered message',
1509     );
1510   } else {
1511     error("Unable to deliver message - is MAPSDeliver setgid? - $!", $status);
1512   } # if
1513
1514   $hit_count++ if $sequence;
1515
1516   RecordHit(
1517     userid   => $userid,
1518     type     => 'white',
1519     sequence => $sequence,
1520     hit_count => $hit_count,
1521   );
1522
1523   return $status;
1524 } # Whitelist
1525
1526 1;