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