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