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