X-Git-Url: https://defaria.com/gitweb/?a=blobdiff_plain;f=maps%2Flib%2FMAPS.pm;h=7573ed5e1275a586f57516debea18ad39448ddcc;hb=7ddf095f187ca60d9a70fb83b2bc3c2b6d91f088;hp=d63f9b9e4ad62b5d3d3b7fa7176f3bc201695440;hpb=9a7e8178524ea77a12d2793791b9630017e1cbe8;p=clearscm.git diff --git a/maps/lib/MAPS.pm b/maps/lib/MAPS.pm index d63f9b9..7573ed5 100644 --- a/maps/lib/MAPS.pm +++ b/maps/lib/MAPS.pm @@ -1,5 +1,4 @@ -#!/usr/bin/perl -################################################################################# +################################################################################ # # File: $RCSfile: MAPS.pm,v $ # Revision: $Revision: 1.1 $ @@ -34,11 +33,12 @@ use base qw(Exporter); 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 @@ -57,6 +57,7 @@ our @EXPORT = qw( CountEmail CountList CountLog + CountLogDistinct Decrypt DeleteEmail DeleteList @@ -154,6 +155,8 @@ sub OpenDB($$) { $db = MyDB->new($username, $password, $dbname, $dbserver); croak "Unable to instantiate MyDB ($username\@$dbserver:$dbname)" unless $db; + + return; } # OpenDB BEGIN { @@ -223,6 +226,7 @@ sub Add2Whitelist(%) { # Add to white list $params{sequence} = 0; + my ($err, $msg) = AddList(%params); return -$err, $msg if $err; @@ -247,7 +251,7 @@ sub Add2Whitelist(%) { while (my $rec = $db->getnext) { last unless $rec->{userid}; - $status = Whitelist($rec->{sender}, $rec->data); + $status = Whitelist($rec->{sender}, $rec->{data}); last if $status; @@ -291,7 +295,7 @@ sub AddList(%) { $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}; @@ -306,6 +310,9 @@ sub AddList(%) { 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); @@ -344,6 +351,7 @@ sub AddUserOptions(%) { } # for return ($err, $msg) if $err; + return; } # AddUserOptions sub Blacklist(%) { @@ -355,7 +363,7 @@ 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}; @@ -403,6 +411,8 @@ sub CheckEmail(;$$) { if ($username) { if ($username =~ /(.*)\@(.*)/) { return lc "$1\@$2"; + } else { + return lc "$username\@"; } # if } elsif ($domain) { if ($domain =~ /(.*)\@(.*)/) { @@ -413,6 +423,68 @@ sub CheckEmail(;$$) { } # 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. @@ -458,7 +530,9 @@ sub CheckOnList ($$;$) { ? "$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; @@ -544,6 +618,8 @@ sub CleanList(%) { 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; @@ -623,7 +699,20 @@ sub CountLog(%) { 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 ($$) { @@ -776,11 +865,7 @@ sub GetUser() { 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($) { @@ -845,13 +930,13 @@ sub Nulllist($;$$) { 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($;$$) { @@ -859,7 +944,7 @@ sub OnWhitelist($;$$) { SetContext($userid) if $userid; - return CheckOnList('white', $sender, $update); + return CheckOnList2('white', $sender, $update); } # OnWhitelist sub OptimizeDB() { @@ -881,67 +966,67 @@ 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 @@ -951,48 +1036,57 @@ sub ReadMsg($) { 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; - $sender =~ s/\//g; - $sender =~ s/\"//g; - $sender =~ 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; + + $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; + } # 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(%) { @@ -1011,7 +1105,7 @@ 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); @@ -1065,7 +1159,7 @@ sub ReturnMsg(%) { # 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}, @@ -1154,21 +1248,27 @@ sub ReturnSenders(%) { 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 @@ -1271,7 +1371,7 @@ sub SetContext($) { if (UserExists($to_user)) { $userid = $to_user; - return GetUserInfo $userid; + return GetUserOptions $userid; } else { return 0; } # if @@ -1306,11 +1406,11 @@ sub UpdateList(%) { 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 @@ -1373,17 +1473,33 @@ sub Whitelist ($$;$$) { 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( @@ -1392,8 +1508,8 @@ sub Whitelist ($$;$$) { 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;