maps/lib/MAPS.pm

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