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