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