-#!/usr/bin/perl
-#################################################################################
+################################################################################
#
# File: $RCSfile: MAPS.pm,v $
# Revision: $Revision: 1.1 $
our $db;
-our $Version = '2.0';
+our $VERSION = '2.0';
# Globals
my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
my %useropts;
+my $mailLoopMax = 5;
our @EXPORT = qw(
Add2Blacklist
CountEmail
CountList
CountLog
+ CountLogDistinct
Decrypt
DeleteEmail
DeleteList
$db = MyDB->new($username, $password, $dbname, $dbserver);
croak "Unable to instantiate MyDB ($username\@$dbserver:$dbname)" unless $db;
+
+ return;
} # OpenDB
BEGIN {
# Add to white list
$params{sequence} = 0;
+
my ($err, $msg) = AddList(%params);
return -$err, $msg if $err;
while (my $rec = $db->getnext) {
last unless $rec->{userid};
- $status = Whitelist($rec->{sender}, $rec->data);
+ $status = Whitelist($rec->{sender}, $rec->{data});
last if $status;
$rec{hit_count} //= $db->count(
'email',
- "userid = '$rec{userid}' and sender like '$rec{sender}%'"
+ "userid = '$rec{userid}' and sender like '%$rec{sender}%'"
);
($rec{pattern}, $rec{domain}) = split /\@/, delete $rec{sender};
sub AddLog(%) {
my (%params) = @_;
+ # Some email senders are coming in mixed case. We don't want that
+ $params{sender} = $params{sender} ? lc $params{sender} : '';
+
$params{timestamp} = UnixDatetime2SQLDatetime(scalar(localtime));
return $db->add('log', %params);
} # for
return ($err, $msg) if $err;
+ return;
} # AddUserOptions
sub Blacklist(%) {
# Check to see if this sender has already emailed us.
my $msg_count = $db->count('email', "userid='$rec{userid}' and sender like '%$rec{sender}%'");
- if ($msg_count < 5) {
+ if ($msg_count < $mailLoopMax) {
# Bounce email
my @spammsg = split "\n", $rec{data};
if ($username) {
if ($username =~ /(.*)\@(.*)/) {
return lc "$1\@$2";
+ } else {
+ return lc "$username\@";
} # if
} elsif ($domain) {
if ($domain =~ /(.*)\@(.*)/) {
} # if
} # CheckEmail
+sub CheckOnList2 ($$;$) {
+ # CheckOnList will check to see if the $sender is on the list. Return 1 if
+ # found 0 if not.
+ my ($listtype, $sender, $update) = @_;
+
+ $update //= 1;
+
+ my ($status, $rule, $sequence);
+
+ my $table = 'list';
+ my $condition = "userid='$userid' and type='$listtype'";
+
+ my ($err, $errmsg) = $db->find($table, $condition, '*', 'order by sequence');
+
+ my ($email_on_file, $rec);
+
+ while ($rec = $db->getnext) {
+ unless ($rec->{domain}) {
+ $email_on_file = $rec->{pattern};
+ } else {
+ unless ($rec->{pattern}) {
+ $email_on_file = '@' . $rec->{domain};
+ } else {
+ $email_on_file = $rec->{pattern} . '@' . $rec->{domain};
+ } # if
+ } # unless
+
+ # Escape some special characters
+ $email_on_file =~ s/\@/\\@/;
+ $email_on_file =~ s/^\*/.\*/;
+
+ # We want to terminate the search string with a "$" iff there's an
+ # "@" in there. This is because some "email_on_file" may have no
+ # domain (e.g. "mailer-daemon" with no domain). In that case we
+ # don't want to terminate the search string with a "$" rather we
+ # wish to terminate it with an "@". But in the case of say
+ # "@ti.com" if we don't terminate the search string with "$" then
+ # "@ti.com" would also match "@tixcom.com"!
+ my $search_for = $email_on_file =~ /\@/
+ ? "$email_on_file\$"
+ : !defined $rec->{domain}
+ ? "$email_on_file\@"
+ : $email_on_file;
+ if ($sender and $sender =~ /$search_for/i) {
+ $status = 1;
+
+ $rec->{hit_count} //= 0;
+
+ RecordHit(
+ userid => $userid,
+ type => $listtype,
+ sequence => $rec->{sequence},
+ hit_count => $rec->{hit_count} + 1,
+ ) if $update;
+
+ last;
+ } # if
+ } # while
+
+ return ($status, $rec);
+} # CheckOnList2
+
sub CheckOnList ($$;$) {
# CheckOnList will check to see if the $sender is on the list. Return 1 if
# found 0 if not.
? "$email_on_file\@"
: $email_on_file;
if ($sender and $sender =~ /$search_for/i) {
- $rule = "Matching rule: ($listtype:$rec->{sequence}) \"$email_on_file\"";
+ my $comment = $rec->{comment} ? " - $rec->{comment}" : '';
+
+ $rule = "Matching rule: ($listtype:$rec->{sequence}) \"$email_on_file$comment\"";
$rule .= " - $rec->{comment}" if $rec->{comment};
$status = 1;
return 0 unless $count;
+ $count = 0;
+
my ($err, $errmsg) = $db->find($table, $condition);
croak "Unable to find $params{type} entries for $condition - $errmsg" if $err;
my $condition = "userid='$userid'";
$condition .= " and $additional_condition" if $additional_condition;
- return $db->count_distinct('log', 'sender', $condition);
+ return $db->count('log', $condition);
+} # CountLog
+
+sub CountLogDistinct(%) {
+ my (%params) = @_;
+
+ CheckParms(['userid', 'column'], \%params);
+
+ my ($additional_condition) = delete $params{additional} || '';
+
+ my $condition = "userid='$userid'";
+ $condition .= " and $additional_condition" if $additional_condition;
+
+ return $db->count_distinct('log', $params{column}, $condition);
} # CountLog
sub Decrypt ($$) {
sub GetUserInfo($) {
my ($userid) = @_;
- my $userinfo = $db->getone('user', "userid='$userid'", ['name', 'email']);
-
return %{$db->getone('user', "userid='$userid'", ['name', 'email'])};
-
- return %$userinfo;
} # GetUserInfo
sub GetUserOptions($) {
sub OnBlacklist($;$) {
my ($sender, $update) = @_;
- return CheckOnList('black', $sender, $update);
+ return CheckOnList2('black', $sender, $update);
} # OnBlacklist
sub OnNulllist($;$) {
my ($sender, $update) = @_;
- return CheckOnList('null', $sender, $update);
+ return CheckOnList2('null', $sender, $update);
} # CheckOnNulllist
sub OnWhitelist($;$$) {
SetContext($userid) if $userid;
- return CheckOnList('white', $sender, $update);
+ return CheckOnList2('white', $sender, $update);
} # OnWhitelist
sub OptimizeDB() {
} # OptimizeDB
sub ReadMsg($) {
- # Reads an email message file from $input. Returns sender, subject,
- # date and data, which is a copy of the entire message.
my ($input) = @_;
- my $sender = '';
- my $sender_long = '';
- my $envelope_sender = '';
- my $reply_to = '';
- my $subject = '';
- my $data = '';
- my @data;
+ my (%msgInfo, @data, $envelope_sender);
- # Find first message's "From " line indicating start of message
+ # Reads an email message file from $input. Returns sender, subject, date and
+ # data, which is a copy of the entire message. Find first message's "From "
+ # line indicating start of message.
while (<$input>) {
chomp;
last if /^From /;
} # while
# If we hit eof here then the message was garbled. Return indication of this
- if (eof($input)) {
- $data = "Garbled message - unable to find From line";
- return $sender, $sender_long, $reply_to, $subject, $data;
- } # if
+ return if eof($input);
if (/From (\S*)/) {
- $envelope_sender = $1;
- $sender_long = $envelope_sender;
+ $msgInfo{sender_long} = $envelope_sender = $1;
} # if
push @data, $_ if /^From /;
while (<$input>) {
- chomp;
+ chomp; chop if /\r$/;
+
push @data, $_;
# Blank line indicates start of message body
- last if ($_ eq "" || $_ eq "\r");
+ last if ($_ eq '' || $_ eq "\r");
# Extract sender's address
- if (/^from: .*/i) {
- $_ = substr ($_, 6);
-
- $sender_long = $_;
-
- if (/<(\S*)@(\S*)>/) {
- $sender = lc ("$1\@$2");
- } elsif (/(\S*)@(\S*)\ /) {
- $sender = lc ("$1\@$2");
- } elsif (/(\S*)@(\S*)/) {
- $sender = lc ("$1\@$2");
+ if (/^from: (.*)/i) {
+ $msgInfo{sender_long} = $msgInfo{sender} = $1;
+
+ if ($msgInfo{sender} =~ /<(\S*)@(\S*)>/) {
+ $msgInfo{sender} = lc ("$1\@$2");
+ } elsif ($msgInfo{sender} =~ /(\S*)@(\S*)\ /) {
+ $msgInfo{sender} = lc ("$1\@$2");
+ } elsif ($msgInfo{sender} =~ /(\S*)@(\S*)/) {
+ $msgInfo{sender} = lc ("$1\@$2");
+ } # if
+ } elsif (/^subject: (.*)/i) {
+ $msgInfo{subject} = $1;
+ } elsif (/^reply-to: (.*)/i) {
+ $msgInfo{reply_to} = $1;
+
+ if ($msgInfo{reply_to} =~ /<(\S*)@(\S*)>/) {
+ $msgInfo{reply_to} = lc ("$1\@$2");
+ } elsif ($msgInfo{reply_to} =~ /(\S*)@(\S*)\ /) {
+ $msgInfo{reply_to} = lc ("$1\@$2");
+ } elsif ($msgInfo{reply_to} =~ /(\S*)@(\S*)/) {
+ $msgInfo{reply_to} = lc ("$1\@$2");
} # if
- } elsif (/^subject: .*/i) {
- $subject = substr ($_, 9);
- } elsif (/^reply-to: .*/i) {
- $_ = substr ($_, 10);
- if (/<(\S*)@(\S*)>/) {
- $reply_to = lc ("$1\@$2");
- } elsif (/(\S*)@(\S*)\ /) {
- $reply_to = lc ("$1\@$2");
- } elsif (/(\S*)@(\S*)/) {
- $reply_to = lc ("$1\@$2");
+ } elsif (/^to: (.*)/i) {
+ $msgInfo{to} = $1;
+
+ if ($msgInfo{to} =~ /<(\S*)@(\S*)>/) {
+ $msgInfo{to} = lc ("$1\@$2");
+ } elsif ($msgInfo{to} =~ /(\S*)@(\S*)\ /) {
+ $msgInfo{to} = lc ("$1\@$2");
+ } elsif ($msgInfo{to} =~ /(\S*)@(\S*)/) {
+ $msgInfo{to} = lc ("$1\@$2");
} # if
} # if
} # while
chomp;
last if (/^From /);
+
push @data, $_;
} # while
# Set file pointer back by length of the line just read
- seek ($input, -length () - 1, 1) if !eof $input;
+ seek ($input, -length() - 1, 1) if !eof $input;
# Sanitize email addresses
- $envelope_sender =~ s/\<//g;
- $envelope_sender =~ s/\>//g;
- $envelope_sender =~ s/\"//g;
- $envelope_sender =~ s/\'//g;
- $sender =~ s/\<//g;
- $sender =~ s/\>//g;
- $sender =~ s/\"//g;
- $sender =~ s/\'//g;
- $reply_to =~ s/\<//g;
- $reply_to =~ s/\>//g;
- $reply_to =~ s/\"//g;
- $reply_to =~ s/\'//g;
+ $envelope_sender =~ s/\<//g;
+ $envelope_sender =~ s/\>//g;
+ $envelope_sender =~ s/\"//g;
+ $envelope_sender =~ s/\'//g;
+
+ $msgInfo{sender} =~ s/\<//g;
+ $msgInfo{sender} =~ s/\>//g;
+ $msgInfo{sender} =~ s/\"//g;
+ $msgInfo{sender} =~ s/\'//g;
+
+ if ($msgInfo{reply_to}) {
+ $msgInfo{reply_to} =~ s/\<//g;
+ $msgInfo{reply_to} =~ s/\>//g;
+ $msgInfo{reply_to} =~ s/\"//g;
+ $msgInfo{reply_to} =~ s/\'//g;
+ } # if
# Determine best addresses
- $sender = $envelope_sender if $sender eq "";
- $reply_to = $sender if $reply_to eq "";
+ $msgInfo{sender} = $envelope_sender unless $msgInfo{sender};
+ $msgInfo{reply_to} = $msgInfo{sender} unless $msgInfo{reply_to};
+
+ $msgInfo{data} = join "\n", @data;
- return $sender, $sender_long, $reply_to, $subject, join "\n", @data;
+ return %msgInfo;
} # ReadMsg
sub RecordHit(%) {
my (%rec) = @_;
- CheckParms(['userid', 'type', 'sequence', ], \%rec);
-
- my $current_date = UnixDatetime2SQLDatetime(scalar(localtime));
+ CheckParms(['userid', 'type', 'sequence'], \%rec);
my $table = 'list';
- my $condition = "userid='rec{userid} and type=$rec{type} and sequence='$rec{sequence}";
+ my $condition = "userid='$rec{userid}' and type='$rec{type}' and sequence='$rec{sequence}'";
- return $db->modify(
- table => $table,
- condition => $condition,
- %rec,
- );
+ # We don't need these fields in %rec as we are not updating them
+ delete $rec{sequence};
+ delete $rec{type};
+ delete $rec{userid};
+
+ # We are, however, updating last_hit
+ $rec{last_hit} = UnixDatetime2SQLDatetime(scalar(localtime));
+
+ return $db->modify($table, $condition, %rec);
} # RecordHit
sub ResequenceList(%) {
$db->lock('write', $table);
# Get all records for $userid and $type
- my $listrecs = $db->get($table, $condition);
+ my $listrecs = $db->get($table, $condition,'*', 'order by hit_count desc');
# Delete all of the list entries for this $userid and $type
my ($count, $msg) = $db->delete($table, $condition);
# Check to see if this sender has already emailed us.
my $msg_count = $db->count('email', "userid='$userid' and sender like '%$params{sender}%'");
- if ($msg_count < 5) {
+ if ($msg_count < $mailLoopMax) {
# Return register message
SendMsg(
userid => $params{userid},
unless $senders{$rec->{sender}};
} # while
- # Make a hash whose keys are the timestamp (so we can later sort on
- # them).
- my %sendersByTimestamp = reverse %senders;
-
- my @senders;
+ my (@unsorted, @senders);
+
+ # Here we have a hash in %senders that has email address and timestamp. In the
+ # past we would merely create a reverse hash by timestamp and sort that. The
+ # The problem is that it is possible for two emails to come in with the same
+ # timestamp. By reversing the hash we clobber any row that has a dumplicte
+ # timestamp. But we want to sort on timestamp. So first we convers this hash
+ # to an array of hashes and then we can sort by timestamp later.
+ while (my ($key, $value) = each %senders) {
+ push @unsorted, {
+ sender => $key,
+ timestamp => $value,
+ };
+ } # while
- # Sort by timestamp desc and push on to the @senders array
- push @senders, $sendersByTimestamp{$_}
- for (sort { $b cmp $a } keys %sendersByTimestamp);
+ push @senders, $_->{sender} for sort { $b->{timestamp} cmp $a->{timestamp}} @unsorted;
# Finally slice for the given range
- my $end_at = $params{start_at} + $params{lines} - 1;
+ my $end_at = $params{start_at} + ($params{lines} - 1);
- $end_at = (@senders - 1)
- if $end_at > @senders;
+ $end_at = (@senders) - 1 if $end_at >= @senders;
return (@senders) [$params{start_at} .. $end_at];
} # ReturnSenders
if (UserExists($to_user)) {
$userid = $to_user;
- return GetUserInfo $userid;
+ return GetUserOptions $userid;
} else {
return 0;
} # if
my $table = 'list';
my $condition = "userid = '$rec{userid}' and type = '$rec{type}' and sequence = $rec{sequence}";
- if ($rec{pattern} =~ /\@/ and !$rec{domain}) {
+ if ($rec{pattern} =~ /\@/ && !$rec{domain}) {
($rec{pattern}, $rec{domain}) = split /\@/, $rec{pattern};
- } elsif (!$rec{pattern} and $rec{domain} =~ /\@/) {
+ } elsif (!$rec{pattern} && $rec{domain} =~ /\@/) {
($rec{pattern}, $rec{domain}) = split /\@/, $rec{domain};
- } elsif (!$rec{pattern} and !$rec{domain}) {
+ } elsif (!$rec{pattern} && !$rec{domain}) {
return "Must specify either Username or Domain";
} # if
my $userid = GetContext;
# Dump message into a file
- open my $message, '>', "/tmp/MAPSMessage.$$"
- or Error("Unable to open message file (/tmp/MAPSMessage.$$): $!\n"), return -1;
+ my $msgfile = "/tmp/MAPSMessage.$$";
+
+ open my $message, '>', $msgfile
+ or error("Unable to open message file ($msgfile): $!\n"), return -1;
print $message $data;
close $message;
# Now call MAPSDeliver
- my $status = system "$FindBin::Bin/MAPSDeliver $userid /tmp/MAPSMessage.$$";
+ my ($status, @output) = Execute "$FindBin::Bin/MAPSDeliver $userid $msgfile";
- unlink "/tmp/MAPSMessage.$$";
+ if ($status != 0) {
+ my $msg = "Unable to deliver message (message left at $msgfile\n\n";
+ $msg .= join "\n", @output;
+
+ Logmsg(
+ userid => $userid,
+ type => 'whitelist',
+ sender => $sender,
+ message => $msg,
+ );
+
+ Error ($msg, 1);
+ } # if
+
+ unlink $msgfile;
if ($status == 0) {
Logmsg(
sender => $sender,
message => 'Delivered message',
);
- } else {
- Error("Unable to deliver message - is MAPSDeliver setgid? - $!");
+ } else {
+ error("Unable to deliver message - is MAPSDeliver setgid? - $!", $status);
} # if
$hit_count++ if $sequence;
projects / clearscm.git / blobdiff