1 ################################################################################
3 # File: $RCSfile: MAPS.pm,v $
4 # Revision: $Revision: 1.1 $
5 # Description: Main module for Mail Authentication and Permission System (MAPS)
6 # Author: Andrew@DeFaria.com
7 # Created: Fri Nov 29 14:17:21 2002
8 # Modified: $Date: 2013/06/12 14:05:47 $
11 # (c) Copyright 2000-2018, Andrew@DeFaria.com, all rights reserved.
13 ################################################################################
32 use base qw(Exporter);
39 my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
104 my $mapsbase = "$FindBin::Bin/..";
107 sub _cleanTables($$;$) {
108 my ($table, $timestamp, $dryrun) = @_;
110 my $condition = "userid = '$userid' and timestamp < '$timestamp'";
113 return $db->count($table, $condition);
115 my ($count, $msg) = $db->delete($table, $condition);
121 sub _retention2Days($) {
122 my ($retention) = @_;
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...
133 # BTW we aren't checking for odd things like 34320 weeks or 5000 years...
134 if ($retention =~ /(\d+)\s+(day|days)/) {
136 } elsif ($retention =~ /(\d+)\s+(week|weeks)/){
138 } elsif ($retention =~ /(\d+)\s+(month|months)/) {
140 } elsif ($retention =~ /(\d+)\s+(year|years)/) {
150 my ($username, $password) = @_;
153 my $dbserver = $ENV{MAPS_SERVER} || 'localhost';
155 $db = MyDB->new($username, $password, $dbname, $dbserver);
157 croak "Unable to instantiate MyDB ($username\@$dbserver:$dbname)" unless $db;
163 my $MAPS_username = "maps";
164 my $MAPS_password = "spam";
166 OpenDB($MAPS_username, $MAPS_password);
169 sub Add2Blacklist(%) {
172 # Add2Blacklist will add an entry to the blacklist
173 # First SetContext to the userid whose black list we are adding to
174 SetContext($params{userid});
177 $params{sequence} = 0;
178 my ($err, $msg) = AddList(%params);
180 # Log that we black listed the sender
181 Info("Added $params{sender} to " . ucfirst $params{userid} . "'s black list");
184 my $count = DeleteEmail(
185 userid => $params{userid},
186 sender => $params{sender},
189 # Log out many emails we managed to remove
190 Info("Removed $count emails from $params{sender}");
195 sub Add2Nulllist(%) {
198 # First SetContext to the userid whose null list we are adding to
199 SetContext($params{userid});
202 $params{sequence} = 0;
203 my ($err, $msg) = AddList(%params);
205 # Log that we null listed the sender
206 Info("Added $params{sender} to " . ucfirst $params{userid }. "'s null list");
209 my $count = DeleteEmail(
210 userid => $params{userid},
211 sender => $params{sender},
214 # Log out many emails we managed to remove
215 Info("Removed $count emails from $params{sender}");
220 sub Add2Whitelist(%) {
223 # Add2Whitelist will add an entry to the whitelist
224 # First SetContext to the userid whose white list we are adding to
225 SetContext($params{userid});
228 $params{sequence} = 0;
230 my ($err, $msg) = AddList(%params);
232 return -$err, $msg if $err;
234 # Log that we registered a user
236 userid => $params{userid},
237 type => 'registered',
238 sender => $params{sender},
239 message => 'Registered new sender',
242 # Check to see if there are any old messages to deliver
243 ($err, $msg) = $db->find('email', "sender = '$params{sender}'", ['userid', 'sender', 'data']);
245 return ($err, $msg) if $err;
251 while (my $rec = $db->getnext) {
252 last unless $rec->{userid};
254 $status = Whitelist($rec->{sender}, $rec->{data});
261 # Return if we has a problem delivering email
262 return -1, 'Problem delivering some email' if $status;
264 # Remove delivered messages
266 userid => $params{userid},
267 sender => $params{sender},
270 return $messages, 'Messages delivered';
276 CheckParms(['userid', 'sender', 'subject', 'data'], \%rec);
278 $rec{timestamp} = UnixDatetime2SQLDatetime(scalar(localtime));
280 return $db->add('email', %rec);
286 CheckParms(['userid', 'type', 'sender', 'sequence'], \%rec);
288 croak "Type $rec{type} not valid. Must be one of white, black or null"
289 unless $rec{type} =~ /(white|black|null)/;
291 croak "Sender must contain \@" unless $rec{sender} =~ /\@/;
293 $rec{retention} //= '';
294 $rec{retention} = lc $rec{retention};
296 $rec{hit_count} //= $db->count(
298 "userid = '$rec{userid}' and sender like '%$rec{sender}%'"
301 ($rec{pattern}, $rec{domain}) = split /\@/, delete $rec{sender};
303 $rec{sequence} = GetNextSequenceNo(%rec);
305 $rec{last_hit} //= UnixDatetime2SQLDatetime(scalar (localtime));
307 return $db->add('list', %rec);
313 # Some email senders are coming in mixed case. We don't want that
314 $params{sender} = $params{sender} ? lc $params{sender} : '';
316 $params{timestamp} = UnixDatetime2SQLDatetime(scalar(localtime));
318 return $db->add('log', %params);
324 CheckParms(['userid', 'name', 'email', 'password'], \%rec);
326 return 1 if UserExists($rec{userid});
328 return $db->add('user', %rec);
331 sub AddUserOptions(%) {
334 croak('Userid is required') unless $rec{userid};
335 croak('No options to add') unless $rec{options};
337 return (1, "User doesn't exists") unless UserExist($rec{userid});
339 my %useropts = delete $rec{userid};
340 my %opts = delete $rec{options};
344 for my $key (%opts) {
345 $useropts{name} = $_;
346 $useropts{value} = $opts{$_};
348 ($err, $msg) = $db->add('useropts', %useropts);
353 return ($err, $msg) if $err;
358 # Blacklist will send a message back to the $sender telling them that
359 # they've been blacklisted. Currently we save a copy of the message.
360 # In the future we should just disregard the message.
363 # Check to see if this sender has already emailed us.
364 my $msg_count = $db->count('email', "userid='$rec{userid}' and sender like '%$rec{sender}%'");
366 if ($msg_count < $mailLoopMax) {
368 my @spammsg = split "\n", $rec{data};
371 userid => $rec{userid},
372 sender => $rec{sender},
373 subject => 'Your email has been discarded by MAPS',
374 msgfile => "$mapsbase/blacklist.html",
381 sender => $rec{sender},
382 message => 'Sent blacklist reply',
388 sender => $rec{sender},
389 message => 'Mail loop encountered',
393 $rec{hit_count}++ if $rec{sequence};
398 sequence => $rec{sequence},
399 hit_count => $rec{hit_count},
405 sub CheckEmail(;$$) {
406 my ($username, $domain) = @_;
408 return lc "$username\@$domain" if $username and $domain;
410 # Check to see if a full email address in either $username or $domain
412 if ($username =~ /(.*)\@(.*)/) {
415 return lc "$username\@";
418 if ($domain =~ /(.*)\@(.*)/) {
426 sub CheckOnList2 ($$;$) {
427 # CheckOnList will check to see if the $sender is on the list. Return 1 if
429 my ($listtype, $sender, $update) = @_;
433 my ($status, $rule, $sequence);
436 my $condition = "userid='$userid' and type='$listtype'";
438 my ($err, $errmsg) = $db->find($table, $condition, '*', 'order by sequence');
440 my ($email_on_file, $rec);
442 while ($rec = $db->getnext) {
443 unless ($rec->{domain}) {
444 $email_on_file = $rec->{pattern};
446 unless ($rec->{pattern}) {
447 $email_on_file = '@' . $rec->{domain};
449 $email_on_file = $rec->{pattern} . '@' . $rec->{domain};
453 # Escape some special characters
454 $email_on_file =~ s/\@/\\@/;
455 $email_on_file =~ s/^\*/.\*/;
457 # We want to terminate the search string with a "$" iff there's an
458 # "@" in there. This is because some "email_on_file" may have no
459 # domain (e.g. "mailer-daemon" with no domain). In that case we
460 # don't want to terminate the search string with a "$" rather we
461 # wish to terminate it with an "@". But in the case of say
462 # "@ti.com" if we don't terminate the search string with "$" then
463 # "@ti.com" would also match "@tixcom.com"!
464 my $search_for = $email_on_file =~ /\@/
466 : !defined $rec->{domain}
469 if ($sender and $sender =~ /$search_for/i) {
472 $rec->{hit_count} //= 0;
477 sequence => $rec->{sequence},
478 hit_count => $rec->{hit_count} + 1,
485 return ($status, $rec);
488 sub CheckOnList ($$;$) {
489 # CheckOnList will check to see if the $sender is on the list. Return 1 if
491 my ($listtype, $sender, $update) = @_;
496 my ($rule, $sequence);
499 my $condition = "userid='$userid' and type='$listtype'";
501 my ($err, $errmsg) = $db->find($table, $condition, '*', 'order by sequence');
503 my ($email_on_file, $rec);
505 while ($rec = $db->getnext) {
506 unless ($rec->{domain}) {
507 $email_on_file = $rec->{pattern};
509 unless ($rec->{pattern}) {
510 $email_on_file = '@' . $rec->{domain};
512 $email_on_file = $rec->{pattern} . '@' . $rec->{domain};
516 # Escape some special characters
517 $email_on_file =~ s/\@/\\@/;
518 $email_on_file =~ s/^\*/.\*/;
520 # We want to terminate the search string with a "$" iff there's an
521 # "@" in there. This is because some "email_on_file" may have no
522 # domain (e.g. "mailer-daemon" with no domain). In that case we
523 # don't want to terminate the search string with a "$" rather we
524 # wish to terminate it with an "@". But in the case of say
525 # "@ti.com" if we don't terminate the search string with "$" then
526 # "@ti.com" would also match "@tixcom.com"!
527 my $search_for = $email_on_file =~ /\@/
529 : !defined $rec->{domain}
532 if ($sender and $sender =~ /$search_for/i) {
533 my $comment = $rec->{comment} ? " - $rec->{comment}" : '';
535 $rule = "Matching rule: ($listtype:$rec->{sequence}) \"$email_on_file$comment\"";
536 $rule .= " - $rec->{comment}" if $rec->{comment};
539 $rec->{hit_count} //= 0;
544 sequence => $rec->{sequence},
545 hit_count => $rec->{hit_count} + 1,
552 return ($status, $rule, $rec->{sequence}, $rec->{hit_count});
555 sub CleanEmail($;$) {
556 my ($timestamp, $dryrun) = @_;
558 return _cleanTables 'email', $timestamp, $dryrun;
562 my ($timestamp, $dryrun) = @_;
564 return _cleanTables('log', $timestamp, $dryrun);
570 CheckParms(['userid', 'type'], \%params);
572 my $dryrunstr = $params{dryrun} ? '(dryrun)' : '';
575 my $condition = "userid='$params{userid}' and type='$params{type}'";
579 # First let's go through the list to see if we have an domain level entry
580 # (e.g. @spammer.com) and also individual entries (baddude@spammer.com) then
581 # we don't really need any of the individual entries since the domain block
583 $db->find($table, $condition, ['domain'], ' and pattern is null');
585 while (my $domains = $db->getnext) {
586 for my $recs ($db->get($table, $condition, ['sequence', 'pattern', 'domain'],
587 " and domain='$domains->{domain}' and pattern is not null")) {
588 if (@$recs and not $params{dryrun}) {
589 for my $rec (@$recs) {
591 userid => $params{userid},
592 type => $params{type},
593 sequence => $rec->{sequence},
596 $params{log}->msg("Deleted $params{userid}:$params{type}:$rec->{sequence} "
597 . "$rec->{pattern}\@$rec->{domain} $dryrunstr")
604 $params{log}->msg("The domain $domains->{domain} has the following subrecords");
606 for my $rec (@$recs) {
607 $params{log}->msg("$rec->{pattern}\@$rec->{domain}");
614 $condition = "userid='$params{userid}' and type='$params{type}' and retention is not null";
616 # First see if anything needs to be deleted
617 ($count, $msg) = $db->count($table, $condition);
619 return 0 unless $count;
623 my ($err, $errmsg) = $db->find($table, $condition);
625 croak "Unable to find $params{type} entries for $condition - $errmsg" if $err;
627 my $todaysDate = Today2SQLDatetime;
629 while (my $rec = $db->getnext) {
630 my $days = _retention2Days($rec->{retention});
632 my $agedDate = SubtractDays($todaysDate, $days);
634 # If last_hit < retentiondays then delete
635 if (Compare($rec->{last_hit}, $agedDate) == -1) {
636 unless ($params{dryrun}) {
638 userid => $params{userid},
639 type => $params{type},
640 sequence => $rec->{sequence},
644 $rec->{pattern} //= '';
645 $rec->{domain} //= '';
647 $params{log}->msg("Deleted $rec->{userid}:$params{type}:$rec->{sequence} "
648 . "$rec->{pattern}\@$rec->{domain} $dryrunstr");
649 $params{log}->dbug("last hit = $rec->{last_hit} < agedDate = $agedDate");
655 $params{log}->dbug("$rec->{userid}:$params{type}:$rec->{sequence}: nodelete $dryrunstr "
656 . "last hit = $rec->{last_hit} >= agedDate = $agedDate")
662 userid => $params{userid},
663 type => $params{type},
664 ) if $count && !$params{dryrun};
672 CheckParms(['userid'], \%params);
675 my $condition = "userid='$params{userid}'";
676 $condition .= " and $params{additional}" if $params{additional};
678 return $db->count($table, $condition);
684 CheckParms(['userid', 'type'], \%params);
687 my $condition = "userid='$params{userid}' and type='$params{type}'";
689 return $db->count($table, $condition);
695 CheckParms(['userid'], \%params);
697 my ($additional_condition) = delete $params{additional} || '';
699 my $condition = "userid='$userid'";
700 $condition .= " and $additional_condition" if $additional_condition;
702 return $db->count('log', $condition);
705 sub CountLogDistinct(%) {
708 CheckParms(['userid', 'column'], \%params);
710 my ($additional_condition) = delete $params{additional} || '';
712 my $condition = "userid='$userid'";
713 $condition .= " and $additional_condition" if $additional_condition;
715 return $db->count_distinct('log', $params{column}, $condition);
719 my ($password, $userid) = @_;
721 return $db->decode($password, $userid);
729 CheckParms(['userid', 'sender'], \%rec);
731 my ($username, $domain) = split /@/, $rec{sender};
735 $condition = "userid = '$rec{userid}' and sender = '$rec{sender}'";
737 $condition = "userid = '$rec{userid}' and sender like '%\@$domain'";
740 return $db->delete($table, $condition);
746 CheckParms(['userid', 'type', 'sequence'], \%rec);
748 my $condition = "userid = '$rec{userid}' and "
749 . "type = '$rec{type}' and "
750 . "sequence = $rec{sequence}";
752 return $db->delete('list', $condition);
756 my ($password, $userid) = @_;
758 return $db->encode($password, $userid);
764 CheckParms(['userid'], \%params);
767 my $condition = "userid='$params{userid}'";
768 $condition .= " and sender='$params{sender}'" if $params{sender};
769 $condition .= " and timestamp='$params{timestamp}'" if $params{timestamp};
771 return $db->find($table, $condition);
777 my ($type, $sender) = @_;
779 CheckParms(['userid', 'type'], \%params);
782 my $condition = "userid='$params{userid}' and type='$params{type}'";
784 if ($params{sender}) {
785 my ($username, $domain) = split /\@/, $params{sender};
787 # Split will return '' if either username or domain is missing. This messes
788 # up SQL's find as '' ~= NULL. Therefore we only specify username or domain
790 $condition .= " and pattern='$username'" if $username;
791 $condition .= " and domain='$domain'" if $domain;
794 return $db->find($table, $condition);
801 my $end_at = CountLog(
806 $start_at = $end_at - abs ($how_many);
807 $start_at = 0 if ($start_at < 0);
811 my $condition = "userid='$userid'";
812 my $additional = "order by timestamp limit $start_at, $end_at";
814 return $db->find($table, $condition, '*', $additional);
823 $condition = "userid='$userid'" if $params{userid};
825 return $db->find($table, $condition, $params{fields});
829 return $db->find('user', '', ['userid']);
848 sub GetNextSequenceNo(%) {
851 CheckParms(['userid', 'type'], \%rec);
854 my $condition = "userid='$rec{userid}' and type='$rec{type}'";
856 my $count = $db->count('list', $condition);
859 } # GetNextSequenceNo
868 return %{$db->getone('user', "userid='$userid'", ['name', 'email'])};
871 sub GetUserOptions($) {
874 my $table = 'useropts';
875 my $condition = "userid='$userid'";
877 $db->find($table, $condition);
881 while (my $rec = $db->getnext) {
882 $useropts{$rec->{name}} = $rec->{value};
889 my ($userid, $password) = @_;
891 $password = Encrypt($password, $userid);
893 # Check if user exists
894 my $dbpassword = UserExists($userid);
896 # Return -1 if user doesn't exist
897 return -1 unless $dbpassword;
899 # Return -2 if password does not match
900 if ($password eq $dbpassword) {
909 # Nulllist will simply discard the message.
910 my ($sender, $sequence, $hit_count) = @_;
915 sequence => $sequence,
916 hit_count => ++$hit_count,
924 message => 'Discarded message'
930 sub OnBlacklist($;$) {
931 my ($sender, $update) = @_;
933 return CheckOnList2('black', $sender, $update);
936 sub OnNulllist($;$) {
937 my ($sender, $update) = @_;
939 return CheckOnList2('null', $sender, $update);
942 sub OnWhitelist($;$$) {
943 my ($sender, $userid, $update) = @_;
945 SetContext($userid) if $userid;
947 return CheckOnList2('white', $sender, $update);
951 my @tables = qw(email list log user useropts);
953 my ($err, $msg) = $db->lock('read', \@tables);
955 croak "Unable to lock table - $msg" if $err;
957 ($err, $msg) = $db->check(\@tables);
959 croak 'Unable to check tables ' . $msg if $err;
961 ($err, $msg) = $db->optimize(\@tables);
963 croak 'Unable to optimize tables ' . $msg if $err;
965 return $db->unlock();
971 my (%msgInfo, @data, $envelope_sender);
973 # Reads an email message file from $input. Returns sender, subject, date and
974 # data, which is a copy of the entire message. Find first message's "From "
975 # line indicating start of message.
981 # If we hit eof here then the message was garbled. Return indication of this
982 return if eof($input);
985 $msgInfo{sender_long} = $envelope_sender = $1;
988 push @data, $_ if /^From /;
991 chomp; chop if /\r$/;
995 # Blank line indicates start of message body
996 last if ($_ eq '' || $_ eq "\r");
998 # Extract sender's address
999 if (/^from: (.*)/i) {
1000 $msgInfo{sender_long} = $msgInfo{sender} = $1;
1002 if ($msgInfo{sender} =~ /<(\S*)@(\S*)>/) {
1003 $msgInfo{sender} = lc ("$1\@$2");
1004 } elsif ($msgInfo{sender} =~ /(\S*)@(\S*)\ /) {
1005 $msgInfo{sender} = lc ("$1\@$2");
1006 } elsif ($msgInfo{sender} =~ /(\S*)@(\S*)/) {
1007 $msgInfo{sender} = lc ("$1\@$2");
1009 } elsif (/^subject: (.*)/i) {
1010 $msgInfo{subject} = $1;
1011 } elsif (/^reply-to: (.*)/i) {
1012 $msgInfo{reply_to} = $1;
1014 if ($msgInfo{reply_to} =~ /<(\S*)@(\S*)>/) {
1015 $msgInfo{reply_to} = lc ("$1\@$2");
1016 } elsif ($msgInfo{reply_to} =~ /(\S*)@(\S*)\ /) {
1017 $msgInfo{reply_to} = lc ("$1\@$2");
1018 } elsif ($msgInfo{reply_to} =~ /(\S*)@(\S*)/) {
1019 $msgInfo{reply_to} = lc ("$1\@$2");
1021 } elsif (/^to: (.*)/i) {
1024 if ($msgInfo{to} =~ /<(\S*)@(\S*)>/) {
1025 $msgInfo{to} = lc ("$1\@$2");
1026 } elsif ($msgInfo{to} =~ /(\S*)@(\S*)\ /) {
1027 $msgInfo{to} = lc ("$1\@$2");
1028 } elsif ($msgInfo{to} =~ /(\S*)@(\S*)/) {
1029 $msgInfo{to} = lc ("$1\@$2");
1043 # Set file pointer back by length of the line just read
1044 seek ($input, -length() - 1, 1) if !eof $input;
1046 # Sanitize email addresses
1047 $envelope_sender =~ s/\<//g;
1048 $envelope_sender =~ s/\>//g;
1049 $envelope_sender =~ s/\"//g;
1050 $envelope_sender =~ s/\'//g;
1052 $msgInfo{sender} =~ s/\<//g;
1053 $msgInfo{sender} =~ s/\>//g;
1054 $msgInfo{sender} =~ s/\"//g;
1055 $msgInfo{sender} =~ s/\'//g;
1057 if ($msgInfo{reply_to}) {
1058 $msgInfo{reply_to} =~ s/\<//g;
1059 $msgInfo{reply_to} =~ s/\>//g;
1060 $msgInfo{reply_to} =~ s/\"//g;
1061 $msgInfo{reply_to} =~ s/\'//g;
1064 # Determine best addresses
1065 $msgInfo{sender} = $envelope_sender unless $msgInfo{sender};
1066 $msgInfo{reply_to} = $msgInfo{sender} unless $msgInfo{reply_to};
1068 $msgInfo{data} = join "\n", @data;
1076 CheckParms(['userid', 'type', 'sequence'], \%rec);
1079 my $condition = "userid='$rec{userid}' and type='$rec{type}' and sequence='$rec{sequence}'";
1081 # We don't need these fields in %rec as we are not updating them
1082 delete $rec{sequence};
1084 delete $rec{userid};
1086 # We are, however, updating last_hit
1087 $rec{last_hit} = UnixDatetime2SQLDatetime(scalar(localtime));
1089 return $db->modify($table, $condition, %rec);
1092 sub ResequenceList(%) {
1095 CheckParms(['userid', 'type'], \%params);
1098 return 1 unless $params{type} =~ /(white|black|null)/;
1099 return 2 unless UserExists($params{userid});
1102 my $condition = "userid='$params{userid}' and type ='$params{type}'";
1105 $db->lock('write', $table);
1107 # Get all records for $userid and $type
1108 my $listrecs = $db->get($table, $condition,'*', 'order by hit_count desc');
1110 # Delete all of the list entries for this $userid and $type
1111 my ($count, $msg) = $db->delete($table, $condition);
1113 # Now re-add list entries renumbering them
1117 $_->{sequence} = $sequence++;
1119 my ($err, $msg) = $db->add($table, %$_);
1132 CheckParms(['userid', 'type'], \%params);
1134 my $start_at = delete $params{start_at} || 0;
1135 my $lines = delete $params{lines} || 10;
1138 my $condition = "userid='$params{userid}' and type='$params{type}'";
1139 my $additional = "order by sequence limit $start_at, $lines";
1141 return $db->get($table, $condition, '*', $additional);
1147 # ReturnMsg will send back to the $sender the register message.
1148 # Messages are saved to be delivered when the $sender registers.
1150 # Added reply_to. Previously we passed reply_to into here as sender. This
1151 # caused a problem in that we were filtering as per sender but logging it
1152 # as reply_to. We only need reply_to for SendMsg so as to honor reply_to
1153 # so we now pass in both sender and reply_to
1155 CheckParms(['userid', 'sender', 'reply_to', 'subject', 'data'], \%params);
1157 #my ($sender, $reply_to, $subject, $data) = @_;
1159 # Check to see if this sender has already emailed us.
1160 my $msg_count = $db->count('email', "userid='$userid' and sender like '%$params{sender}%'");
1162 if ($msg_count < $mailLoopMax) {
1163 # Return register message
1165 userid => $params{userid},
1166 sender => $params{reply_to},
1167 subject => 'Your email has been returned by MAPS',
1168 msgfile => "$mapsbase/register.html",
1169 data => $params{data},
1170 ) if $msg_count == 0;
1173 userid => $params{userid},
1175 sender => $params{sender},
1176 message => 'Sent register reply',
1180 SaveMsg($params{sender}, $params{subject}, $params{data});
1182 Add2Nulllist($params{sender}, GetContext, "Auto Null List - Mail loop");
1185 userid => $params{userid},
1187 sender => $params{sender},
1188 message => 'Mail loop encountered',
1195 sub ReturnMessages(%) {
1198 CheckParms(['userid', 'sender'], \%params);
1200 my $table = 'email';
1201 my $condition = "userid='$params{userid}' and sender='$params{sender}'";
1202 my $fields = ['subject', 'timestamp'];
1203 my $additional = 'group by timestamp desc';
1205 return $db->get($table, $condition, $fields, $additional);
1208 sub ReturnSenders(%) {
1210 # This subroutine returns an array of senders in reverse chronological
1211 # order based on time timestamp from the log table of when we returned
1212 # their message. The complication here is that a single sender may
1213 # send multiple times in a single day. So if spammer@foo.com sends
1214 # spam @ 1 second after midnight and then again at 2 Pm there will be
1215 # at least two records in the log table saying that we returned his
1216 # email. Getting records sorted by timestamp desc will have
1217 # spammer@foo.com listed twice. But we want him listed only once, as
1218 # the first entry in the returned array. Plus we may be called
1219 # repeatedly with different $start_at's. Therefore we need to process
1220 # the whole list of returns for today, eliminate duplicate entries for
1221 # a single sender then slice the resulting array.
1222 CheckParms(['userid', 'type', 'lines'], \%params);
1225 my $condition = "userid='$params{userid}' and type='$params{type}'";
1226 my $additional = 'order by timestamp desc';
1228 $params{start_at} ||= 0;
1230 if ($params{date}) {
1231 $condition .= "and timestamp > '$params{date} 00:00:00' and "
1232 . "timestamp < '$params{date} 23:59:59'";
1235 $db->find($table, $condition, '*', $additional);
1237 # Watch the distinction between senders (plural) and sender (singular)
1240 # Run through the results and add to %senders by sender key. This
1241 # results in a hash that has the sender in it and the first
1242 # timestamp value. Since we already sorted timestamp desc by the
1243 # above select statement, and we've narrowed it down to only log
1244 # message that occurred for the given $date, we will have a hash
1245 # containing 1 sender and the latest timestamp for the day.
1246 while (my $rec = $db->getnext) {
1247 $senders{$rec->{sender}} = $rec->{timestamp}
1248 unless $senders{$rec->{sender}};
1251 my (@unsorted, @senders);
1253 # Here we have a hash in %senders that has email address and timestamp. In the
1254 # past we would merely create a reverse hash by timestamp and sort that. The
1255 # The problem is that it is possible for two emails to come in with the same
1256 # timestamp. By reversing the hash we clobber any row that has a dumplicte
1257 # timestamp. But we want to sort on timestamp. So first we convers this hash
1258 # to an array of hashes and then we can sort by timestamp later.
1259 while (my ($key, $value) = each %senders) {
1262 timestamp => $value,
1266 push @senders, $_->{sender} for sort { $b->{timestamp} cmp $a->{timestamp}} @unsorted;
1268 # Finally slice for the given range
1269 my $end_at = $params{start_at} + ($params{lines} - 1);
1271 $end_at = (@senders) - 1 if $end_at >= @senders;
1273 return (@senders) [$params{start_at} .. $end_at];
1277 my ($sender, $subject, $data) = @_;
1282 subject => $subject,
1289 sub SearchEmails(%) {
1292 CheckParms(['userid', 'search'], \%params);
1294 my $table = 'email';
1295 my $fields = ['sender', 'subject', 'timestamp'];
1296 my $condition = "userid='$params{userid}' and (sender like '\%$params{search}\%' "
1297 . "or subject like '\%$params{search}\%')";
1298 my $additional = 'order by timestamp desc';
1300 my ($err, $msg) = $db->find($table, $condition, $fields, $additional);
1304 while (my $rec = $db->getnext) {
1312 # SendMsg will send the message contained in $msgfile.
1315 #my ($sender, $subject, $msgfile, $userid, @spammsg) = @_;
1319 # Open return message template file
1320 open my $return_msg_file, '<', $params{msgfile}
1321 or die "Unable to open return msg file ($params{msgfile}): $!\n";
1323 # Read return message template file and print it to $msg_body
1324 while (<$return_msg_file>) {
1327 s/\$userid/$userid/;
1331 s/\$sender/$params{sender}/;
1337 close $return_msg_file;
1339 # Create the message, and set up the mail headers:
1340 my $msg = MIME::Entity->build(
1341 From => "MAPS\@DeFaria.com",
1342 To => $params{sender},
1343 Subject => $params{subject},
1344 Type => "text/html",
1348 # Need to obtain the spam message here...
1349 my @spammsg = split "\n", $params{data};
1353 Disposition => "attachment",
1358 open my $mail, '|-', '/usr/lib/sendmail -t -oi -oem'
1359 or croak "SendMsg: Unable to open pipe to sendmail $!";
1361 $msg->print(\*$mail);
1371 if (UserExists($to_user)) {
1374 return GetUserOptions $userid;
1383 my $total_space = 0;
1384 my $table = 'email';
1385 my $condition = "userid='$userid'";
1387 $db->find($table, $condition);
1389 while (my $rec = $db->getnext) {
1391 length($rec->{userid}) +
1392 length($rec->{sender}) +
1393 length($rec->{subject}) +
1394 length($rec->{timestamp}) +
1395 length($rec->{data});
1398 return $total_space;
1404 CheckParms(['userid', 'type', 'sequence'], \%rec);
1407 my $condition = "userid = '$rec{userid}' and type = '$rec{type}' and sequence = $rec{sequence}";
1409 if ($rec{pattern} =~ /\@/ && !$rec{domain}) {
1410 ($rec{pattern}, $rec{domain}) = split /\@/, $rec{pattern};
1411 } elsif (!$rec{pattern} && $rec{domain} =~ /\@/) {
1412 ($rec{pattern}, $rec{domain}) = split /\@/, $rec{domain};
1413 } elsif (!$rec{pattern} && !$rec{domain}) {
1414 return "Must specify either Username or Domain";
1417 $rec{pattern} //= 'null';
1418 $rec{domain} //= 'null';
1419 $rec{comment} //= 'null';
1421 if ($rec{retention}) {
1422 $rec{retention} = lc $rec{retention};
1425 return $db->update($table, $condition, %rec);
1431 CheckParms(['userid', 'name', 'email'], \%rec);
1433 return 1 unless UserExists($rec{userid});
1436 my $condition = "userid='$rec{userid}'";
1438 return $db->update($table, $condition, %rec);
1441 sub UpdateUserOptions ($@) {
1442 my ($userid, %options) = @_;
1444 return unless UserExists($userid);
1446 my $table = 'useropts';
1447 my $condition = "userid='$userid' and name=";
1449 $db->update($table, "$condition'$_'", (name=>$_, value=>$options{$_})) for (keys %options);
1452 } # UpdateUserOptions
1457 return 0 unless $userid;
1460 my $condition = "userid='$userid'";
1462 my $rec = $db->get($table, $condition);
1464 return 0 if scalar(@$rec) == 0;
1466 return $rec->[0]{password};
1469 sub Whitelist ($$;$$) {
1470 # Whitelist will deliver the message.
1471 my ($sender, $data, $sequence, $hit_count) = @_;
1473 my $userid = GetContext;
1475 # Dump message into a file
1476 open my $message, '>', "/tmp/MAPSMessage.$$"
1477 or error("Unable to open message file (/tmp/MAPSMessage.$$): $!\n"), return -1;
1479 print $message $data;
1483 # Now call MAPSDeliver
1484 my ($status, @output) = Execute "$FindBin::Bin/MAPSDeliver $userid /tmp/MAPSMessage.$$";
1485 #my $status = system "$FindBin::Bin/MAPSDeliver $userid /tmp/MAPSMessage.$$";
1488 my $msg = "Unable to deliver message (message left at /tmp/MAPSMessage.%%\n\n";
1489 $msg .= join "\n", @output;
1493 type => 'whitelist',
1501 unlink "/tmp/MAPSMessage.$$";
1506 type => 'whitelist',
1508 message => 'Delivered message',
1511 error("Unable to deliver message - is MAPSDeliver setgid? - $!", $status);
1514 $hit_count++ if $sequence;
1519 sequence => $sequence,
1520 hit_count => $hit_count,