Многопоточный прокси на Perl, или как покупать на books.ru удобно

Пообщались мы как-то с пользователем icoz по поводу покупок в books.ru и решения, как не купить одну и туже книжку случайно дважды. Диалог получился не очень, а вот решение вышло удобное и показывающее, какие книжки куплены, а какие — нет. Причем, никаких параметров для скрипта не надо. Скрипт получит логин и пароль для взаимодействия с сайтом сам. Если вы купили что-то, то достаточно выйти с сайта books.ru и зайти обратно, чтоб скрипт подхватил купленные Вами книги.

Что нам понадобится?

Машина с установленным перлом и операционной системой Ubuntu (но подойдет любой Linux) под Windows есть проблемы, из-за используемого fork , но их можно победить установив модуль через CPAN with force. Тесты он все равно не пройдет, но нужная нам часть заработает.

Шаг 1: Устанавливаем необходимые библиотеки. Если они уже установлены, бояться не надо — второй раз они не установятся. Для любителей ActivePerl есть ppm.bat

sudo apt-get install liburi-encode-perl libwww-perl libhtml-tokeparser-simple-perl libwww-mechanize-perl libdatetime-perl libhttp-proxy-perl

Шаг 2: Создаем proxy server не забыв установить нужные фильтры:

my $proxy = HTTP::Proxy->new( engine => 'Threaded', port=>8888, max_keep_alive_requests => 0, host=>'127.0.0.1', timeout=>120);
my $filter = HTTP::Proxy::BodyFilter::simple->new(\&alter_page);
$proxy->push_filter(mime   => 'text/html', response => HTTP::Proxy::BodyFilter::complete->new(), response => $filter); 
$proxy->push_filter(method  => 'POST', path =>'/member/login.php', request => HTTP::Proxy::HeaderFilter::simple->new(sub {
	my $booklog = uri_decode($1) if $_[2]->decoded_content =~ /login\=(.*?)(?:\&|$)/;
	my $bookpsw = uri_decode($1) if $_[2]->decoded_content =~ /password\=(.*?)(?:\&|$)/;
	my @new_books = init_proxy($booklog, $bookpsw, @OWN_BOOKS);
	{lock (@OWN_BOOKS); @OWN_BOOKS = @new_books;}
	})); 

И запускаем его:

$proxy->start;

Используется два фильтра:

• Для модификации страницы: alter_page
• Для захвата логина и пароля: наименованная функция

Важные моменты:

• engine => 'Threaded'. Если выбрать что-либо иное под Windows не заработает, а под Linux заработает с ошибками из-за fork().
• {lock ( @OWN_BOOKS); @OWN_BOOKS = @new_books;}. Если написать напрямую, то возможны проблемы, ибо perl не считает нужным заботиться о многопоточности и считает все переменные thread local.

Шаг 3: Пишем фильтр модификации:

sub alter_page
{ 
  my ( $self, $dataref, $message, $protocol, $buffer ) = @_;
  return unless ${$dataref};
  return unless $message->headers->content_type;
  foreach my $haveid (@OWN_BOOKS)
  {
    my $str = $haveid.'/?show=1"';
    my $spat = quotemeta $str;
    my $repl = $str." style=\"text-decoration: line-through;\"";
    ${$dataref} =~ s/$spat/$repl/sg;
  }
}

Тут все просто: создаем нужный шаблон для замены пробегаясь по всем имеющимся у нас книжкам, и отмечаем их как купленные путем зачеркивания!

Шаг 4: Пишем инициализацию пробегаясь по всем заказам и собирая все книжки которые вы уже купили.

  foreach my $order_id (@order_list)
  {
    $resp = $mech->get('http://www.books.ru/order.php?order='.$order_id);
    parse_hrefs($resp->decoded_content, sub {push @OWN_BOOKS, $1 if ($_[0] =~ /(\d+)\/download\/\?file_type\=\w{3}/);});
  }
  my %seen = ();
  my @ubooks = grep { ! $seen{$_}++ } @OWN_BOOKS;

В конце, убираем из списка все повторы, если таковые есть.

Шаг 5: Казалось бы все, должно работать, но не работает, ибо надо написать:

my @OWN_BOOKS :shared;

В противном случае глобальная переменная @OWN_BOOKS будет для каждого потока своя.
Шаг 6: Устанавливаем FoxyProxy или любое иное расширение, позволяющее использовать per site proxy, и наслаждаемся удобной работай с сайтом books.ru.

Как обычно, прилагаю полный скрипт

#!/usr/bin/perl
use WWW::Mechanize;
use HTTP::Request::Common;
use LWP;
use LWP::UserAgent;
use HTML::TokeParser;
use DateTime;
use Encode qw(decode encode);
use HTTP::Proxy;
use HTTP::Proxy::BodyFilter::simple;
use HTTP::Proxy::Engine::Threaded;
use HTTP::Proxy::BodyFilter::complete;
use HTTP::Proxy::HeaderFilter::simple;
use URI::Encode qw(uri_encode uri_decode);
use threads;
use threads::shared;
use warnings;

# initialisation
binmode STDOUT, ":utf8";

my @OWN_BOOKS;
share(@OWN_BOOKS);
@OWN_BOOKS = ();
my $proxy = HTTP::Proxy->new( engine => 'Threaded', port=>8888, max_keep_alive_requests => 0, host=>'127.0.0.1', timeout=>120);
   $proxy->engine()->max_clients(100);

my $filter = HTTP::Proxy::BodyFilter::simple->new(\&alter_page);
$proxy->push_filter(mime   => 'text/html', response => HTTP::Proxy::BodyFilter::complete->new(), response => $filter); # 
$proxy->push_filter(method  => 'POST', path =>'/member/login.php', request => HTTP::Proxy::HeaderFilter::simple->new(sub {
	my $booklog = uri_decode($1) if $_[2]->decoded_content =~ /login\=(.*?)(?:\&|$)/;
	my $bookpsw = uri_decode($1) if $_[2]->decoded_content =~ /password\=(.*?)(?:\&|$)/;
	my @new_books = init_proxy($booklog, $bookpsw, @OWN_BOOKS);
	{lock (@OWN_BOOKS); @OWN_BOOKS = @new_books;}
        print "You already has ".scalar @OWN_BOOKS." books.\n"; 
	})); 
# this is a MainLoop-like method
$proxy->start;


sub init_proxy
{
  my $mail = shift;
  my $password = shift;
  my @OWN_BOOKS = @_;

  my $mech = WWW::Mechanize->new();
  $mech->agent_alias("Linux Mozilla");
  my $resp = $mech->get('http://www.books.ru/member/login.php');
  $mech->cookie_jar->set_cookie(0, 'cookie_first_timestamp',DateTime->now->epoch, '/', 'www.books.ru');
  $mech->cookie_jar->set_cookie(0, 'cookie_pages', '1', '/', 'www.books.ru');
  $resp = $mech->post('http://www.books.ru/member/login.php',[
      'login'  => $mail,
      'password' => $password,
      'go' => 'login',
      'x' => rand_from_to(20, 55), 'y' => rand_from_to(10, 19), 
      'token' => ''
    ]);
  $resp = $mech->get('http://www.books.ru/member/orders/');
  my @order_list = $resp->decoded_content =~ /\<a\shref=\"http:\/\/www\.books\.ru\/order.php\?order\=(\d+)\"\>/gi;
  foreach my $order_id (@order_list)
  {
    $resp = $mech->get('http://www.books.ru/order.php?order='.$order_id);
    parse_hrefs($resp->decoded_content, sub {push @OWN_BOOKS, $1 if ($_[0] =~ /(\d+)\/download\/\?file_type\=\w{3}/);});
  }
  my %seen = ();
  my @ubooks = grep { ! $seen{$_}++ } @OWN_BOOKS;
  return @ubooks;
}

sub parse_hrefs
{
  my ($data, $functor) = @_;
  my $stream = HTML::TokeParser->new(\$data);
  $stream->empty_element_tags(1);
  while (my $token = $stream->get_token) 
  {
    if ($token->[0] eq 'S' && $token->[1] eq 'a') 
    {
      my $href = $token->[2]{'href'};
      $functor->($href);
    }
  }

}

sub alter_page
{ 
  my ( $self, $dataref, $message, $protocol, $buffer ) = @_;
  return unless ${$dataref};
  return unless $message->headers->content_type;
  #print scalar @OWN_BOOKS."!!!!!\n";
  foreach my $haveid (@OWN_BOOKS)
  {
    my $str = $haveid.'/?show=1"';
    my $spat = quotemeta $str;
    my $repl = $str." style=\"text-decoration: line-through;\"";
    ${$dataref} =~ s/$spat/$repl/sg;
  }
}

sub rand_from_to
{
  my($from, $to) = @_;
  return int(rand($to - $from)) + $from;
}

PS: Если будет таково желание общества, то могу разместить модифицированную версию на своем сервере, хотя я бы сам ни за какие удобства не стал пользоваться неконтролируемым мной прокси.