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