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 $table     = 'list';
1072   my $condition = "userid='$rec{userid}' and type='$rec{type}' and sequence='$rec{sequence}'";
1073
1074   # We don't need these fields in %rec as we are not updating them
1075   delete $rec{sequence};
1076   delete $rec{type};
1077   delete $rec{userid};
1078
1079   # We are, however, updating last_hit
1080   $rec{last_hit} = UnixDatetime2SQLDatetime(scalar(localtime));
1081
1082   return $db->modify($table, $condition, %rec);
1083 } # RecordHit
1084
1085 sub ResequenceList(%) {
1086   my (%params) = @_;
1087
1088   CheckParms(['userid', 'type'], \%params);
1089
1090   # Data checks
1091   return 1 unless $params{type} =~ /(white|black|null)/;
1092   return 2 unless UserExists($params{userid});
1093
1094   my $table     = 'list';
1095   my $condition = "userid='$params{userid}' and type ='$params{type}'";
1096
1097   # Lock the table
1098   $db->lock('write', $table);
1099
1100   # Get all records for $userid and $type
1101   my $listrecs = $db->get($table, $condition,'*', 'order by hit_count desc');
1102
1103   # Delete all of the list entries for this $userid and $type
1104   my ($count, $msg) = $db->delete($table, $condition);
1105
1106   # Now re-add list entries renumbering them
1107   my $sequence = 1;
1108
1109   for (@$listrecs) {
1110     $_->{sequence} = $sequence++;
1111
1112     my ($err, $msg) = $db->add($table, %$_);
1113
1114     croak $msg if $err;
1115   } # for
1116
1117   $db->unlock;
1118
1119   return 0;
1120 } # ResequenceList
1121
1122 sub ReturnList(%) {
1123   my (%params) = @_;
1124
1125   CheckParms(['userid', 'type'], \%params);
1126
1127   my $start_at = delete $params{start_at} || 0;
1128   my $lines    = delete $params{lines}    || 10;
1129
1130   my $table      = 'list';
1131   my $condition  = "userid='$params{userid}' and type='$params{type}'";
1132   my $additional = "order by sequence limit $start_at, $lines";
1133
1134   return $db->get($table, $condition, '*', $additional);
1135 } # ReturnList
1136
1137 sub ReturnMsg(%) {
1138   my (%params) = @_;
1139
1140   # ReturnMsg will send back to the $sender the register message.
1141   # Messages are saved to be delivered when the $sender registers.
1142   #
1143   # Added reply_to. Previously we passed reply_to into here as sender. This
1144   # caused a problem in that we were filtering as per sender but logging it
1145   # as reply_to. We only need reply_to for SendMsg so as to honor reply_to
1146   # so we now pass in both sender and reply_to
1147
1148   CheckParms(['userid', 'sender', 'reply_to', 'subject', 'data'], \%params);
1149
1150   #my ($sender, $reply_to, $subject, $data) = @_;
1151
1152   # Check to see if this sender has already emailed us.
1153   my $msg_count = $db->count('email', "userid='$userid' and sender like '%$params{sender}%'");
1154
1155   if ($msg_count < 5) {
1156     # Return register message
1157     SendMsg(
1158       userid   => $params{userid},
1159       sender   => $params{reply_to},
1160       subject  => 'Your email has been returned by MAPS',
1161       msgfile  => "$mapsbase/register.html",
1162       data     => $params{data},
1163     ) if $msg_count == 0;
1164
1165     Logmsg(
1166       userid  => $params{userid},
1167       type    => 'returned',
1168       sender  => $params{sender},
1169       message => 'Sent register reply',
1170     );
1171
1172     # Save message
1173     SaveMsg($params{sender}, $params{subject}, $params{data});
1174   } else {
1175     Add2Nulllist($params{sender}, GetContext, "Auto Null List - Mail loop");
1176
1177     Logmsg(
1178       userid  => $params{userid},
1179       type    => 'mailloop',
1180       sender  => $params{sender},
1181       message => 'Mail loop encountered',
1182     );
1183   } # if
1184
1185   return;
1186 } # ReturnMsg
1187
1188 sub ReturnMessages(%) {
1189   my (%params) = @_;
1190
1191   CheckParms(['userid', 'sender'], \%params);
1192
1193   my $table      = 'email';
1194   my $condition  = "userid='$params{userid}' and sender='$params{sender}'";
1195   my $fields     = ['subject', 'timestamp'];
1196   my $additional = 'group by timestamp desc';
1197
1198   return $db->get($table, $condition, $fields, $additional);
1199 } # ReturnMessages
1200
1201 sub ReturnSenders(%) {
1202   my (%params) = @_;
1203   # This subroutine returns an array of senders in reverse chronological
1204   # order based on time timestamp from the log table of when we returned
1205   # their message. The complication here is that a single sender may
1206   # send multiple times in a single day. So if spammer@foo.com sends
1207   # spam @ 1 second after midnight and then again at 2 Pm there will be
1208   # at least two records in the log table saying that we returned his
1209   # email. Getting records sorted by timestamp desc will have
1210   # spammer@foo.com listed twice. But we want him listed only once, as
1211   # the first entry in the returned array. Plus we may be called
1212   # repeatedly with different $start_at's. Therefore we need to process
1213   # the whole list of returns for today, eliminate duplicate entries for
1214   # a single sender then slice the resulting array.
1215   CheckParms(['userid', 'type', 'lines'], \%params);
1216
1217   my $table      = 'log';
1218   my $condition  = "userid='$params{userid}' and type='$params{type}'";
1219   my $additional = 'order by timestamp desc';
1220
1221   $params{start_at} ||= 0;
1222
1223   if ($params{date}) {
1224     $condition .= "and timestamp > '$params{date} 00:00:00' and "
1225                .      "timestamp < '$params{date} 23:59:59'";
1226   } # if
1227
1228   $db->find($table, $condition, '*', $additional);
1229
1230   # Watch the distinction between senders (plural) and sender (singular)
1231   my %senders;
1232
1233   # Run through the results and add to %senders by sender key. This
1234   # results in a hash that has the sender in it and the first
1235   # timestamp value. Since we already sorted timestamp desc by the
1236   # above select statement, and we've narrowed it down to only log
1237   # message that occurred for the given $date, we will have a hash
1238   # containing 1 sender and the latest timestamp for the day.
1239   while (my $rec = $db->getnext) {
1240     $senders{$rec->{sender}} = $rec->{timestamp}
1241       unless $senders{$rec->{sender}};
1242   } # while
1243
1244   my (@unsorted, @senders);
1245
1246   # Here we have a hash in %senders that has email address and timestamp. In the
1247   # past we would merely create a reverse hash by timestamp and sort that. The
1248   # The problem is that it is possible for two emails to come in with the same
1249   # timestamp. By reversing the hash we clobber any row that has a dumplicte
1250   # timestamp. But we want to sort on timestamp. So first we convers this hash
1251   # to an array of hashes and then we can sort by timestamp later.
1252   while (my ($key, $value) = each %senders) {
1253     push @unsorted, {
1254       sender    => $key,
1255       timestamp => $value,
1256     };
1257   } # while
1258
1259   push @senders, $_->{sender} for sort { $b->{timestamp} cmp $a->{timestamp}} @unsorted;
1260
1261   # Finally slice for the given range
1262   my $end_at = $params{start_at} + ($params{lines} - 1);
1263
1264   $end_at = (@senders) - 1 if $end_at >= @senders;
1265
1266   return (@senders) [$params{start_at} .. $end_at];
1267 } # ReturnSenders
1268
1269 sub SaveMsg($$$) {
1270   my ($sender, $subject, $data) = @_;
1271
1272   AddEmail(
1273     userid  => $userid,
1274     sender  => $sender,
1275     subject => $subject,
1276     data    => $data,
1277   );
1278
1279   return;
1280 } # SaveMsg
1281
1282 sub SearchEmails(%) {
1283   my (%params) = @_;
1284
1285   CheckParms(['userid', 'search'], \%params);
1286
1287   my $table      = 'email';
1288   my $fields     = ['sender', 'subject', 'timestamp'];
1289   my $condition  = "userid='$params{userid}' and (sender like '\%$params{search}\%' "
1290                  . "or subject like '\%$params{search}\%')";
1291   my $additional = 'order by timestamp desc';
1292
1293   my ($err, $msg) = $db->find($table, $condition, $fields, $additional);
1294
1295   my @emails;
1296
1297   while (my $rec = $db->getnext) {
1298     push @emails, $rec;
1299   } # while
1300
1301   return @emails;
1302 } # SearchEmails
1303
1304 sub SendMsg(%) {
1305   # SendMsg will send the message contained in $msgfile.
1306   my (%params) = @_;
1307
1308   #my ($sender, $subject, $msgfile, $userid, @spammsg) = @_;
1309
1310   my @lines;
1311
1312   # Open return message template file
1313   open my $return_msg_file, '<', $params{msgfile}
1314     or die "Unable to open return msg file ($params{msgfile}): $!\n";
1315
1316   # Read return message template file and print it to $msg_body
1317   while (<$return_msg_file>) {
1318     if (/\$userid/) {
1319       # Replace userid
1320       s/\$userid/$userid/;
1321     } # if
1322     if (/\$sender/) {
1323       # Replace sender
1324       s/\$sender/$params{sender}/;
1325     } #if
1326
1327     push @lines, $_;
1328   } # while
1329
1330   close $return_msg_file;
1331
1332   # Create the message, and set up the mail headers:
1333   my $msg = MIME::Entity->build(
1334     From    => "MAPS\@DeFaria.com",
1335     To      => $params{sender},
1336     Subject => $params{subject},
1337     Type    => "text/html",
1338     Data    => \@lines
1339   );
1340
1341   # Need to obtain the spam message here...
1342   my @spammsg = split "\n", $params{data};
1343
1344   $msg->attach(
1345     Type        => "message",
1346     Disposition => "attachment",
1347     Data        => \@spammsg
1348   );
1349
1350   # Send it
1351   open my $mail, '|-', '/usr/lib/sendmail -t -oi -oem'
1352     or croak "SendMsg: Unable to open pipe to sendmail $!";
1353
1354   $msg->print(\*$mail);
1355
1356   close $mail;
1357
1358   return;
1359 } # SendMsg
1360
1361 sub SetContext($) {
1362   my ($to_user) = @_;
1363
1364   if (UserExists($to_user)) {
1365     $userid = $to_user;
1366
1367     return GetUserOptions $userid;
1368   } else {
1369     return 0;
1370   } # if
1371 } # SetContext
1372
1373 sub Space($) {
1374   my ($userid) = @_;
1375
1376   my $total_space = 0;
1377   my $table       = 'email';
1378   my $condition   = "userid='$userid'";
1379
1380   $db->find($table, $condition);
1381
1382   while (my $rec = $db->getnext) {
1383     $total_space +=
1384       length($rec->{userid})    +
1385       length($rec->{sender})    +
1386       length($rec->{subject})   +
1387       length($rec->{timestamp}) +
1388       length($rec->{data});
1389   } # while
1390
1391   return $total_space;
1392 } # Space
1393
1394 sub UpdateList(%) {
1395   my (%rec) = @_;
1396
1397   CheckParms(['userid', 'type', 'sequence'], \%rec);
1398
1399   my $table     = 'list';
1400   my $condition = "userid = '$rec{userid}' and type = '$rec{type}' and sequence = $rec{sequence}";
1401
1402   if ($rec{pattern} =~ /\@/ && !$rec{domain}) {
1403     ($rec{pattern}, $rec{domain}) = split /\@/, $rec{pattern};
1404   } elsif (!$rec{pattern} && $rec{domain} =~ /\@/) {
1405     ($rec{pattern}, $rec{domain}) = split /\@/, $rec{domain};
1406   } elsif (!$rec{pattern} && !$rec{domain}) {
1407     return "Must specify either Username or Domain";
1408   } # if
1409
1410   $rec{pattern}   //= 'null';
1411   $rec{domain}    //= 'null';
1412   $rec{comment}   //= 'null';
1413
1414   if ($rec{retention}) {
1415     $rec{retention} = lc $rec{retention};
1416   } # if
1417
1418   return $db->update($table, $condition, %rec);
1419 } # UpdateList
1420
1421 sub UpdateUser(%) {
1422   my (%rec) = @_;
1423
1424   CheckParms(['userid', 'name', 'email'], \%rec);
1425
1426   return 1 unless UserExists($rec{userid});
1427
1428   my $table = 'user';
1429   my $condition = "userid='$rec{userid}'";
1430
1431   return $db->update($table, $condition, %rec);
1432 } # UpdateUser
1433
1434 sub UpdateUserOptions ($@) {
1435   my ($userid, %options)  = @_;
1436
1437   return unless UserExists($userid);
1438
1439   my $table     = 'useropts';
1440   my $condition = "userid='$userid' and name=";
1441
1442   $db->update($table, "$condition'$_'", (name=>$_, value=>$options{$_})) for (keys %options);
1443
1444   return;
1445 } # UpdateUserOptions
1446
1447 sub UserExists($) {
1448   my ($userid) = @_;
1449
1450   return 0 unless $userid;
1451
1452   my $table     = 'user';
1453   my $condition = "userid='$userid'";
1454
1455   my $rec = $db->get($table, $condition);
1456
1457   return 0 if scalar(@$rec) == 0;
1458
1459   return $rec->[0]{password};
1460 } # UserExists
1461
1462 sub Whitelist ($$;$$) {
1463   # Whitelist will deliver the message.
1464   my ($sender, $data, $sequence, $hit_count) = @_;
1465
1466   my $userid = GetContext;
1467
1468   # Dump message into a file
1469   open my $message, '>', "/tmp/MAPSMessage.$$"
1470     or Error("Unable to open message file (/tmp/MAPSMessage.$$): $!\n"), return -1;
1471
1472   print $message $data;
1473
1474   close $message;
1475
1476   # Now call MAPSDeliver
1477   my $status = system "$FindBin::Bin/MAPSDeliver $userid /tmp/MAPSMessage.$$";
1478
1479   unlink "/tmp/MAPSMessage.$$";
1480
1481   if ($status == 0) {
1482     Logmsg(
1483       userid  => $userid,
1484       type    => 'whitelist',
1485       sender  => $sender,
1486       message => 'Delivered message',
1487     );
1488   } else {
1489     Error("Unable to deliver message - is MAPSDeliver setgid? - $!");
1490   } # if
1491
1492   $hit_count++ if $sequence;
1493
1494   RecordHit(
1495     userid   => $userid,
1496     type     => 'white',
1497     sequence => $sequence,
1498     hit_count => $hit_count,
1499   );
1500
1501   return $status;
1502 } # Whitelist
1503
1504 1;