lj + perl VS spambot
Те, кто состиоит в различных жж-сообществах, уже, наверно, заметили некоторое количество спама в них же.
В очередной раз эта проблема была поднята, к примеру, в matmex: дискуссия.
Я не к месту вылез с предположением, что модераторы вполне могут автоматизировать процесс добавления в сообщество. А как вы знаете, "доносчику - первый кнут". Потом как всегда развелся "на слабо" и слабал прототипчик на perl. Ключевые слова: cpan и LiveHttpHeaders.
#!/usr/bin/env perl
# 02 Oct 2009
# gark87 aka Arkady Galyash
#
# For matmex LJ community - automate new members approval
use strict;
use warnings;
# for mail use IMAP with ssl
# gmail.com, for example, use IMAP with SSL
use Net::IMAP::Simple::SSL;
use Email::Simple;
# for LJ posting
use LWP::UserAgent;
use HTTP::Request::Common qw(POST);
# constants
use constant CORRECT => '***correct***';
use constant INCORRECT => '***incorrect***';
use constant DONE => '***done***';
# load config
require "config.pl";
# let 'browser' have cookies
my $browser = LWP::UserAgent->new;
$browser->cookie_jar( {} );
#
# generate Question and Answer for this %username%
#
sub generate_QA($)
{
my ($member) = @_;
return ('2*2=?', '4');
}
#
# only mail logic should be here
#
sub read_mail($)
{
my ($imap) = @_;
my $requests = {};
my $answers = {};
# community name
my $community = mmLJ->community;
# test that directory with new members requests exists
my $nm = $imap->select(mmMail->requests);
defined $nm or
die "No folder `requests' on mail account. Check config and mail account.\n";
# process requests
foreach my $i (1..$nm)
{
my $es = Email::Simple->new(join '', @{ $imap->top($i) } );
if ($es->header('Subject') =~
m/$community membership request by (.*)\!/)
{
my $user = $1;
my ($question, $answer) = generate_QA($user);
$requests->{$user} = $question;
}
}
# test that directory with comments-answers exists
$nm = $imap->select(mmMail->answers);
defined $nm or
die "No folder `answers' on mail account. Check config and mail account.\n";
# check answers
foreach my $i (1..$nm)
{
my $es = Email::Simple->new(join '', @{ $imap->top($i) } );
if ($es->header('From') =~
m/"([^ ]+) - LJ Comment" \@livejournal.com>/)
{
my $user = $1;
my ($question, $answer) = generate_QA($user);
# get the message, returned as a reference to an array of lines
my @lines = @{ $imap->get( $i ) };
my $reply;
my $flag;
# cut off needed information from mail to $reply variable
foreach my $line (@lines)
{
# start from this line
if ($line =~ m/Their reply was:/)
{
$flag = 1;
}
else
{
# end with this line
if ($line =~ m/From here, you can:/)
{
undef $flag;
}
else
{
# all between them copy to $line var
if (defined $flag)
{
$line =~ s/=[\r\n]+$//g;
$reply .= $line;
}
}
}
}
# delete all html tags. leave only text
$reply =~ s/<[^>]+>//g;
# Presumption of "noscere"
$answers->{$user} = INCORRECT;
foreach my $line (split(/[\n\r]+/, $reply))
{
if ($line =~ m/^[ \t]*$answer[ \t]*$/)
{
$answers->{$user} = CORRECT;
}
}
}
}
return ($requests, $answers);
}
#
# do LJ login for cookies only
#
sub LJ_login()
{
my $user = mmLJ->moderator;
my $pass = mmLJ->password;
my $req = POST "http://www.livejournal.com/login.bml",
[
user => $user,
password => $pass
];
$browser->request($req);
}
#
# send private messages with questions to LJ users
#
sub send_LJ_pm(\%)
{
my ($pms) = @_;
# get lj_form_auth field
my $auth;
my $req = POST "http://www.livejournal.com/inbox/compose.bml" ;
my $res = $browser->request($req);
if ($res->content =~ m/name="lj_form_auth" value="([^"]+)"/)
{
$auth = $1;
}
else
{
die "Cannot get into inbox.\n";
}
foreach my $user (keys %{ $pms })
{
my $question = $pms->{$user};
# already done
if ($question eq DONE)
{
next;
}
my $dir = '/inbox/compose.bml';
my $body = 'You receive this message because you want to join matmex LJ community. For complete registration, please, answer the question in the subject of this message as comment to post http://community.livejournal.com/matmextest/415.html';
my $req = POST "http://www.livejournal.com/inbox/compose.bml",
[
msg_subject => $question,
msg_body => $body,
msg_to => $user,
lj_form_auth => $auth,
mode => 'send'
];
my $res = $browser->request($req);
if (-1 != index($res->content,
'Your message has been sent successfully'))
{
$pms->{$user} = DONE;
}
}
}
sub LJ_approve(\%)
{
my ($aps) = @_;
my $community = mmLJ->community;
my $req = HTTP::Request->new(GET =>
"http://www.livejournal.com/community/pending.bml?authas=$community");
my $res = $browser->request($req);
my $page = $res->content;
my $auth;
my $ids;
if ($page =~ m/name="lj_form_auth" value="([^"]+)"/)
{
$auth = $1;
}
if ($page =~ m/name="ids" value="([0-9,]+)"/)
{
$ids = $1;
}
(defined $auth and defined $ids) or
die "Cannot get into community\n";
my $reject_opts ={
lj_form_auth => $auth,
reject => 'Reject membership',
ids => $ids
};
my $approve_opts = {
lj_form_auth => $auth,
approve => 'Approve membership',
ids => $ids
};
foreach my $user (keys %{ $aps })
{
if ($page =~ m/$user'/)
{
my $index = $1;
if ($aps->{$user} eq CORRECT)
{
$approve_opts->{$index} = 'on';
}
else
{
if ($aps->{$user} eq INCORRECT)
{
$reject_opts->{$index} = 'on';
}
else
{
die "Wrong value";
}
}
print "$user - $index\n";
}
}
my $approve_result;
my $reject_result;
if (keys %{$approve_opts} > 3)
{
$req = POST "http://www.livejournal.com/community/pending.bml?authas=$community", $approve_opts;
my $page = $browser->request($req)->content;
if ($page =~ m/You have added ([0-9]+) persons? to this community./ and
$1+3 == keys %{$approve_opts})
{
$approve_result = 1;
}
}
if (keys %{$reject_opts} > 3)
{
$req = POST "http://www.livejournal.com/community/pending.bml?authas=$community", $reject_opts ;
my $page = $browser->request($req)->content;
if ($page =~ m/You have rejected ([0-9]+) requests? to join this community./ and
$1+3 == keys %{$reject_opts})
{
$reject_result = 1;
}
}
foreach my $user (keys %{ $aps })
{
if ($aps->{$user} eq CORRECT and $approve_result)
{
$aps->{$user} = DONE;
}
if ($aps->{$user} eq INCORRECT and $reject_result)
{
$aps->{$user} = DONE;
}
}
}
sub delete_mail($\%\%)
{
my ($imap, $req, $app) = @_;
my $community = mmLJ->community;
# test that directory with new members requests exists
my $nm = $imap->select(mmMail->requests);
defined $nm or
die "No folder `requests' on mail account. Check config and mail account.\n";
foreach my $i (1..$nm)
{
my $es = Email::Simple->new(join '', @{ $imap->top($i) } );
if ($es->header('Subject') =~
m/$community membership request by (.*)\!/)
{
if ($req->{$1} eq DONE)
{
$imap->delete($i);
}
}
}
# test that directory with comments-answers exists
$nm = $imap->select(mmMail->answers);
defined $nm or
die "No folder `answers' on mail account. Check config and mail account.\n";
# check answers
foreach my $i (1..$nm)
{
my $es = Email::Simple->new(join '', @{ $imap->top($i) } );
if ($es->header('From') =~
m/"([^ ]+) - LJ Comment" \@livejournal.com>/)
{
if ($app->{$1} eq DONE)
{
$imap->delete($i);
}
}
}
}
my $imap = Net::IMAP::Simple::SSL->new(mmMail->server) or
die "Unable to connect to mail\n";
defined $imap->login(mmMail->user, mmMail->password) or
die "Unable to login to mail\n";
my ($requests, $approves) = read_mail($imap);
my %lj_requests = %{ $requests };
my %lj_approves = %{ $approves };
if (keys %lj_requests or keys %lj_approves)
{
LJ_login();
if (keys %lj_requests)
{
send_LJ_pm(%lj_requests);
}
if (keys %lj_approves)
{
LJ_approve(%lj_approves);
}
delete_mail($imap, %lj_requests, %lj_approves);
}
$imap->quit;
Сильно сомневаюсь, что его кто-нибудь будет использовать, но я его здесь напишу по следующим причинам:
1) чтоб не потерялось, вдруг когда-нить буду писать спам-бота для жж =)
2) чтоб выслушать, что не так с моим Perl кодом, ну то есть покритикуйте, кто хочет.(критику "я бы писал это на Python, OCaml, Java, C#, C, Asm, Brainfuck, ..." просьба не писать писать только с кодом)
3) чтоб еще раз иметь повод сказать, что SUP занимается какой-то фигней.
В очередной раз эта проблема была поднята, к примеру, в matmex: дискуссия.
Я не к месту вылез с предположением, что модераторы вполне могут автоматизировать процесс добавления в сообщество. А как вы знаете, "доносчику - первый кнут". Потом как всегда развелся "на слабо" и слабал прототипчик на perl. Ключевые слова: cpan и LiveHttpHeaders.
#!/usr/bin/env perl
# 02 Oct 2009
# gark87 aka Arkady Galyash
#
# For matmex LJ community - automate new members approval
use strict;
use warnings;
# for mail use IMAP with ssl
# gmail.com, for example, use IMAP with SSL
use Net::IMAP::Simple::SSL;
use Email::Simple;
# for LJ posting
use LWP::UserAgent;
use HTTP::Request::Common qw(POST);
# constants
use constant CORRECT => '***correct***';
use constant INCORRECT => '***incorrect***';
use constant DONE => '***done***';
# load config
require "config.pl";
# let 'browser' have cookies
my $browser = LWP::UserAgent->new;
$browser->cookie_jar( {} );
#
# generate Question and Answer for this %username%
#
sub generate_QA($)
{
my ($member) = @_;
return ('2*2=?', '4');
}
#
# only mail logic should be here
#
sub read_mail($)
{
my ($imap) = @_;
my $requests = {};
my $answers = {};
# community name
my $community = mmLJ->community;
# test that directory with new members requests exists
my $nm = $imap->select(mmMail->requests);
defined $nm or
die "No folder `requests' on mail account. Check config and mail account.\n";
# process requests
foreach my $i (1..$nm)
{
my $es = Email::Simple->new(join '', @{ $imap->top($i) } );
if ($es->header('Subject') =~
m/$community membership request by (.*)\!/)
{
my $user = $1;
my ($question, $answer) = generate_QA($user);
$requests->{$user} = $question;
}
}
# test that directory with comments-answers exists
$nm = $imap->select(mmMail->answers);
defined $nm or
die "No folder `answers' on mail account. Check config and mail account.\n";
# check answers
foreach my $i (1..$nm)
{
my $es = Email::Simple->new(join '', @{ $imap->top($i) } );
if ($es->header('From') =~
m/"([^ ]+) - LJ Comment" \@livejournal.com>/)
{
my $user = $1;
my ($question, $answer) = generate_QA($user);
# get the message, returned as a reference to an array of lines
my @lines = @{ $imap->get( $i ) };
my $reply;
my $flag;
# cut off needed information from mail to $reply variable
foreach my $line (@lines)
{
# start from this line
if ($line =~ m/Their reply was:/)
{
$flag = 1;
}
else
{
# end with this line
if ($line =~ m/From here, you can:/)
{
undef $flag;
}
else
{
# all between them copy to $line var
if (defined $flag)
{
$line =~ s/=[\r\n]+$//g;
$reply .= $line;
}
}
}
}
# delete all html tags. leave only text
$reply =~ s/<[^>]+>//g;
# Presumption of "noscere"
$answers->{$user} = INCORRECT;
foreach my $line (split(/[\n\r]+/, $reply))
{
if ($line =~ m/^[ \t]*$answer[ \t]*$/)
{
$answers->{$user} = CORRECT;
}
}
}
}
return ($requests, $answers);
}
#
# do LJ login for cookies only
#
sub LJ_login()
{
my $user = mmLJ->moderator;
my $pass = mmLJ->password;
my $req = POST "http://www.livejournal.com/login.bml",
[
user => $user,
password => $pass
];
$browser->request($req);
}
#
# send private messages with questions to LJ users
#
sub send_LJ_pm(\%)
{
my ($pms) = @_;
# get lj_form_auth field
my $auth;
my $req = POST "http://www.livejournal.com/inbox/compose.bml" ;
my $res = $browser->request($req);
if ($res->content =~ m/name="lj_form_auth" value="([^"]+)"/)
{
$auth = $1;
}
else
{
die "Cannot get into inbox.\n";
}
foreach my $user (keys %{ $pms })
{
my $question = $pms->{$user};
# already done
if ($question eq DONE)
{
next;
}
my $dir = '/inbox/compose.bml';
my $body = 'You receive this message because you want to join matmex LJ community. For complete registration, please, answer the question in the subject of this message as comment to post http://community.livejournal.com/matmextest/415.html';
my $req = POST "http://www.livejournal.com/inbox/compose.bml",
[
msg_subject => $question,
msg_body => $body,
msg_to => $user,
lj_form_auth => $auth,
mode => 'send'
];
my $res = $browser->request($req);
if (-1 != index($res->content,
'Your message has been sent successfully'))
{
$pms->{$user} = DONE;
}
}
}
sub LJ_approve(\%)
{
my ($aps) = @_;
my $community = mmLJ->community;
my $req = HTTP::Request->new(GET =>
"http://www.livejournal.com/community/pending.bml?authas=$community");
my $res = $browser->request($req);
my $page = $res->content;
my $auth;
my $ids;
if ($page =~ m/name="lj_form_auth" value="([^"]+)"/)
{
$auth = $1;
}
if ($page =~ m/name="ids" value="([0-9,]+)"/)
{
$ids = $1;
}
(defined $auth and defined $ids) or
die "Cannot get into community\n";
my $reject_opts ={
lj_form_auth => $auth,
reject => 'Reject membership',
ids => $ids
};
my $approve_opts = {
lj_form_auth => $auth,
approve => 'Approve membership',
ids => $ids
};
foreach my $user (keys %{ $aps })
{
if ($page =~ m/$user'/)
{
my $index = $1;
if ($aps->{$user} eq CORRECT)
{
$approve_opts->{$index} = 'on';
}
else
{
if ($aps->{$user} eq INCORRECT)
{
$reject_opts->{$index} = 'on';
}
else
{
die "Wrong value";
}
}
print "$user - $index\n";
}
}
my $approve_result;
my $reject_result;
if (keys %{$approve_opts} > 3)
{
$req = POST "http://www.livejournal.com/community/pending.bml?authas=$community", $approve_opts;
my $page = $browser->request($req)->content;
if ($page =~ m/You have added ([0-9]+) persons? to this community./ and
$1+3 == keys %{$approve_opts})
{
$approve_result = 1;
}
}
if (keys %{$reject_opts} > 3)
{
$req = POST "http://www.livejournal.com/community/pending.bml?authas=$community", $reject_opts ;
my $page = $browser->request($req)->content;
if ($page =~ m/You have rejected ([0-9]+) requests? to join this community./ and
$1+3 == keys %{$reject_opts})
{
$reject_result = 1;
}
}
foreach my $user (keys %{ $aps })
{
if ($aps->{$user} eq CORRECT and $approve_result)
{
$aps->{$user} = DONE;
}
if ($aps->{$user} eq INCORRECT and $reject_result)
{
$aps->{$user} = DONE;
}
}
}
sub delete_mail($\%\%)
{
my ($imap, $req, $app) = @_;
my $community = mmLJ->community;
# test that directory with new members requests exists
my $nm = $imap->select(mmMail->requests);
defined $nm or
die "No folder `requests' on mail account. Check config and mail account.\n";
foreach my $i (1..$nm)
{
my $es = Email::Simple->new(join '', @{ $imap->top($i) } );
if ($es->header('Subject') =~
m/$community membership request by (.*)\!/)
{
if ($req->{$1} eq DONE)
{
$imap->delete($i);
}
}
}
# test that directory with comments-answers exists
$nm = $imap->select(mmMail->answers);
defined $nm or
die "No folder `answers' on mail account. Check config and mail account.\n";
# check answers
foreach my $i (1..$nm)
{
my $es = Email::Simple->new(join '', @{ $imap->top($i) } );
if ($es->header('From') =~
m/"([^ ]+) - LJ Comment" \@livejournal.com>/)
{
if ($app->{$1} eq DONE)
{
$imap->delete($i);
}
}
}
}
my $imap = Net::IMAP::Simple::SSL->new(mmMail->server) or
die "Unable to connect to mail\n";
defined $imap->login(mmMail->user, mmMail->password) or
die "Unable to login to mail\n";
my ($requests, $approves) = read_mail($imap);
my %lj_requests = %{ $requests };
my %lj_approves = %{ $approves };
if (keys %lj_requests or keys %lj_approves)
{
LJ_login();
if (keys %lj_requests)
{
send_LJ_pm(%lj_requests);
}
if (keys %lj_approves)
{
LJ_approve(%lj_approves);
}
delete_mail($imap, %lj_requests, %lj_approves);
}
$imap->quit;
Сильно сомневаюсь, что его кто-нибудь будет использовать, но я его здесь напишу по следующим причинам:
1) чтоб не потерялось, вдруг когда-нить буду писать спам-бота для жж =)
2) чтоб выслушать, что не так с моим Perl кодом, ну то есть покритикуйте, кто хочет.(критику "я бы писал это на Python, OCaml, Java, C#, C, Asm, Brainfuck, ..." просьба не писать писать только с кодом)
3) чтоб еще раз иметь повод сказать, что SUP занимается какой-то фигней.