SVN: toys/rsget.pl/RSGet: Captcha.pm Curl.pm Get.pm HTTPRequest.pm HTTPServer.pm Processor.pm Wait.p...
sparky
sparky at pld-linux.org
Sun Sep 13 13:21:19 CEST 2009
Author: sparky
Date: Sun Sep 13 13:21:18 2009
New Revision: 10590
Added:
toys/rsget.pl/RSGet/Captcha.pm
toys/rsget.pl/RSGet/Wait.pm
Modified:
toys/rsget.pl/RSGet/Curl.pm
toys/rsget.pl/RSGet/Get.pm
toys/rsget.pl/RSGet/HTTPRequest.pm
toys/rsget.pl/RSGet/HTTPServer.pm
toys/rsget.pl/RSGet/Processor.pm
Log:
- Wait separated from Get
- added Captcha, module which asks the user to solve captcha
Added: toys/rsget.pl/RSGet/Captcha.pm
==============================================================================
--- (empty file)
+++ toys/rsget.pl/RSGet/Captcha.pm Sun Sep 13 13:21:18 2009
@@ -0,0 +1,84 @@
+package RSGet::Captcha;
+
+use strict;
+use warnings;
+use Digest::MD5 qw(md5_hex);
+use RSGet::Tools;
+
+our %needed;
+our %solved;
+
+my %waiting;
+sub captcha
+{
+ my $self = shift;
+ my $next_stage = shift;
+ my $ct = shift;
+
+ my $md5 = md5_hex( $self->{body} );
+
+ $needed{ $md5 } = [ $ct, $self->{body} ];
+
+ $self->linedata( captcha => $md5 );
+
+ $self->{captcha_md5} = $md5;
+ $self->{captcha_next} = $next_stage;
+ $self->{captcha_until} = time + 100;
+
+ my $id = 0;
+ ++$id while exists $waiting{ $id };
+ $waiting{ $id } = $self;
+}
+
+sub solved
+{
+ my $self = shift;
+ my $captcha = shift;
+
+ $self->{body} = $captcha;
+ $_ = $captcha;
+
+ $self->linedata();
+ my $func = $self->{captcha_next};
+ &$func( $self );
+}
+
+sub unsolved
+{
+ my $self = shift;;
+
+ delete $self->{body};
+ $_ = undef;
+
+ $self->linedata();
+ $self->start();
+}
+
+sub captcha_update
+{
+ my $time = time;
+
+ foreach my $id ( keys %waiting ) {
+ my $obj = $waiting{ $id };
+ my $left = $obj->{captcha_until} - $time;
+ if ( $left <= 0 ) {
+ delete $waiting{ $id };
+ delete $needed{ $obj->{captcha_md5} };
+ $obj->print( "captcha not solved" );
+ unsolved( $obj );
+ } elsif ( $obj->{_abort} ) {
+ delete $waiting{ $id };
+ $obj->abort();
+ } elsif ( my $s = $solved{ $obj->{captcha_md5} } ) {
+ delete $waiting{ $id };
+ solved( $obj, $s );
+ } else {
+ $obj->print( "solve captcha " . s2string( $left ) );
+ }
+ }
+ RSGet::Line::status( 'captcha' => scalar keys %waiting );
+}
+
+1;
+
+# vim:ts=4:sw=4
Modified: toys/rsget.pl/RSGet/Curl.pm
==============================================================================
--- toys/rsget.pl/RSGet/Curl.pm (original)
+++ toys/rsget.pl/RSGet/Curl.pm Sun Sep 13 13:21:18 2009
@@ -149,7 +149,7 @@
}
my $fname;
- if ( $supercurl->{head} =~ /^Content-Disposition:\s*attachment;\s*filename\s*=\s*"?(.*?)"?\s*$/im ) {
+ if ( $supercurl->{head} =~ /^Content-Disposition:\s*attachment;\s*filename\s*=\s*"?(.+?)"?\s*$/i ) {
$fname = de_ml( uri_unescape( $1 ) );
} else {
my $eurl = $curl->getinfo( CURLINFO_EFFECTIVE_URL );
Modified: toys/rsget.pl/RSGet/Get.pm
==============================================================================
--- toys/rsget.pl/RSGet/Get.pm (original)
+++ toys/rsget.pl/RSGet/Get.pm Sun Sep 13 13:21:18 2009
@@ -3,8 +3,15 @@
use strict;
use warnings;
use RSGet::Tools;
+use RSGet::Captcha;
+use RSGet::Wait;
use URI;
+BEGIN {
+ our @ISA;
+ @ISA = qw(RSGet::Wait RSGet::Captcha);
+}
+
my %cookies;
sub make_cookie
{
@@ -304,77 +311,6 @@
RSGet::FileList::update();
}
-my %waiting;
-sub wait
-{
- my $self = shift;
- my $next_stage = shift;
- my $wait = shift;
- my $msg = shift || "???";
- my $reason = shift || "wait";
-
- $self->linedata( wait => $reason );
-
- my $time = time;
- delete $self->{wait_until_should};
-
- my $rnd_wait = int rand ( 5 * 60 ) + 2 * 60;
- if ( $wait > $rnd_wait + 1 * 60 ) {
- $self->{wait_until_should} = $time + $wait;
- $wait = $rnd_wait;
- }
- $wait = - $wait if $wait < 0;
- $wait += int rand 10;
-
- $self->{wait_next} = $next_stage;
- $self->{wait_msg} = $msg;
- $self->{wait_until} = $time + $wait;
-
- my $id = 0;
- ++$id while exists $waiting{ $id };
- $waiting{ $id } = $self;
-}
-
-sub wait_finish
-{
- my $self = shift;;
-
- delete $self->{body};
- $_ = undef;
-
- $self->linedata();
- my $func = $self->{wait_next};
- &$func( $self );
-}
-
-sub wait_update
-{
- my $time = time;
-
- foreach my $id ( keys %waiting ) {
- my $obj = $waiting{ $id };
- my $left = $obj->{wait_until} - $time;
- if ( $left <= 0 ) {
- delete $waiting{ $id };
- $obj->print( $obj->{wait_msg} . "; done waiting" );
- wait_finish( $obj );
- } elsif ( $obj->{_abort} ) {
- delete $waiting{ $id };
- $obj->abort();
- } else {
- if ( $obj->{wait_until_should} ) {
- $obj->print( sprintf "%s; should wait %s, retrying in %s",
- $obj->{wait_msg},
- s2string( $obj->{wait_until_should} - $time),
- s2string( $left ) );
- } else {
- $obj->print( $obj->{wait_msg} . "; waiting " . s2string( $left ) );
- }
- }
- }
- RSGet::Line::status( 'waiting' => scalar keys %waiting );
-}
-
1;
# vim:ts=4:sw=4
Modified: toys/rsget.pl/RSGet/HTTPRequest.pm
==============================================================================
--- toys/rsget.pl/RSGet/HTTPRequest.pm (original)
+++ toys/rsget.pl/RSGet/HTTPRequest.pm Sun Sep 13 13:21:18 2009
@@ -15,6 +15,7 @@
"log" => \&log,
add => \&add,
add_update => \&add_update,
+ captcha => \&captcha,
);
my %lastid;
@@ -65,6 +66,7 @@
my $r = xhtml_start( "main.js" );
$r .= f_status();
+ $r .= f_notify();
$r .= f_active();
$r .= f_log( 6 );
$r .= f_dllist();
@@ -84,6 +86,8 @@
command( $post->{exec} ) if $post->{exec};
+ $r .= f_notify();
+
my $data = {};
my $nowactive = scalar keys %RSGet::Line::active;
if ( $nowactive or not exists $post->{active} or $post->{active} != $nowactive ) {
@@ -130,6 +134,25 @@
return $r;
}
+sub f_notify
+{
+ my $r = '<fieldset id="f_notify"><legend>notify</legend><ul>';
+ foreach my $md5 ( keys %RSGet::Captcha::needed ) {
+ $r .= qq#<li id="captcha_$md5" class="captcha"><img src="/captcha?md5=$md5" />#;
+ $r .= qq#<iframe id="ic_$md5" name="ic_$md5" src="about:blank" />#;
+ $r .= qq#<form method="post" action="/captcha" target="ic_$md5">#;
+ $r .= qq#<input type="hidden" name="md5" value="$md5" />#;
+ $r .= qq#<input type="text" name="solve" />#;
+ $r .= qq#<input type="submit" name="ok" value="ok" />#;
+ $r .= qq#</form></li>#;
+ }
+
+ $r .= '</ul></fieldset>';
+ return $r;
+}
+
+
+
sub f_active
{
$lastid{act} = {};
@@ -138,7 +161,6 @@
my $line = $RSGet::Line::active{ $key };
$r .= act_info( $line );
- #$r .= qq#<li><span>$name</span>$value</li>\n#;
}
$r .= '</ul></fieldset>';
@@ -161,7 +183,7 @@
my $uri = $o->{uri};
my $uriid = makeid( "act", $uri, $uri );
my $name = sgml( $o->{name} );
- my $size = bignum( $o->{size} );
+ my $size = ($o->{size} =~ /^\d+$/) ? bignum( $o->{size} ) . " bytes" : sgml( $o->{size} );
$logo =~ s/ $//;
$uri = sgml( $uri );
@@ -174,7 +196,7 @@
return qq#<li id="$uriid" class="active $color">#
. qq#<span class="logo">$logo</span>#
. qq#<div class="href"><a href="$uri">$uri</a></div>#
- . qq#<div class="info"><span class="size">$size bytes</span>$name</div>#
+ . qq#<div class="info"><span class="size">$size</span>$name</div>#
. qq#<div class="progress">$prog<span>$line</span></div>#
. '</li>';
}
@@ -240,7 +262,7 @@
|| $o->{aname} || $o->{ainame};
$bestname = sgml( $bestname || "???" );
- my $bestsize = $o->{size} ? bignum( $o->{size} ) : sgml( $o->{asize} || "?" );
+ my $bestsize = $o->{size} ? bignum( $o->{size} ) . " bytes" : sgml( $o->{asize} || "?" );
my $uriid = makeid( $id_type, $uri, $uri );
my $color = "blue";
@@ -608,6 +630,32 @@
return $r;
}
+sub captcha
+{
+ my ( $file, $post, $headers ) = @_;
+
+ my $ct;
+ my $data;
+ my $md5 = $post->{md5};
+ if ( $post->{solve} ) {
+ delete $RSGet::Captcha::needed{ $md5 };
+ $RSGet::Captcha::solved{ $md5 } = $post->{solve};
+ $headers->{Content_Type} = "text/plain";
+ return $post->{solve};
+ } elsif ( my $n = $RSGet::Captcha::needed{ $md5 } ) {
+ ( $ct, $data ) = @$n;
+ } else {
+ $ct = "image/png";
+ local $/ = undef;
+ open F_IN, '<', $main::data_path . "/data/error.png";
+ $data = <F_IN>;
+ close F_IN;
+ }
+
+ $headers->{Content_Type} = $ct;
+ return $data;
+}
+
1;
# vim: ts=4:sw=4
Modified: toys/rsget.pl/RSGet/HTTPServer.pm
==============================================================================
--- toys/rsget.pl/RSGet/HTTPServer.pm (original)
+++ toys/rsget.pl/RSGet/HTTPServer.pm Sun Sep 13 13:21:18 2009
@@ -71,6 +71,7 @@
}
my( $method, $file, $ignore ) = split /\s+/, $request;
+ $file =~ s#^/+##;
my %post;
if ( uc $method eq "POST" and length $post ) {
@@ -81,9 +82,10 @@
s/%(..)/chr hex $1/eg;
$post{ $key } = $_;
}
+ } elsif ( $file =~ s/\?(.*)// ) {
+ my $get = $1;
+ %post = map /^(.*?)=(.*)/, split /;+/, $get;
}
-
- $file =~ s#^/+##;
my $print;
if ( my $func = $RSGet::HTTPRequest::handlers{$file} ) {
$print = "HTTP/1.1 200 OK\r\n";
Modified: toys/rsget.pl/RSGet/Processor.pm
==============================================================================
--- toys/rsget.pl/RSGet/Processor.pm (original)
+++ toys/rsget.pl/RSGet/Processor.pm Sun Sep 13 13:21:18 2009
@@ -141,7 +141,8 @@
s/^(\s+)//;
$space = $1;
- if ( s/^GET\s*\(// ) {
+ if ( s/^(GET|WAIT|CAPTCHA)\s*\(// ) {
+ my $cmd = lc $1;
my $next_stage = "stage" . ++$stage;
my @skip;
push @skip, $_;
@@ -153,15 +154,16 @@
$next_stage = $1;
shift @machine;
}
- p_ret( "get", "\\&$next_stage" );
+ p_ret( $cmd, "\\&$next_stage" );
foreach ( @skip ) {
p_line();
}
p_subend();
p_sub( $next_stage );
- } elsif ( s/^GET_NEXT\s*\(\s*(.*?)\s*,// ) {
- my $next_stage = $1;
- p_ret( "get", "\\&$1" );
+ } elsif ( s/^(GET|WAIT|CAPTCHA)_NEXT\s*\(\s*(.*?)\s*,// ) {
+ my $cmd = lc $1;
+ my $next_stage = $2;
+ p_ret( $cmd, "\\&$2" );
p_line();
} elsif ( s/^ERROR\s*\(// ) {
p_ret( "error" );
@@ -172,28 +174,6 @@
} elsif ( s/^SEARCH\s*\(// ) {
pr $space . 'return if $self->search( ';
p_line();
- } elsif ( s/^WAIT\s*\(// ) {
- my $next_stage = "stage" . ++$stage;
- my @skip;
- push @skip, $_;
- until ( /;\s*$/ ) {
- $_ = shift @machine;
- push @skip, $_;
- }
- if ( $machine[0] =~ s/^(stage_.*?):\s*$// ) {
- $next_stage = $1;
- shift @machine;
- }
- p_ret( "wait", "\\&$next_stage" );
- foreach ( @skip ) {
- p_line();
- }
- p_subend();
- p_sub( $next_stage );
- } elsif ( s/^WAIT_NEXT\s*\(\s*(.*?)\s*,// ) {
- my $next_stage = $1;
- p_ret( "wait", "\\&$next_stage" );
- p_line();
} elsif ( s/^RESTART\s*\(\s*// ) {
p_ret( "restart" );
p_line();
Added: toys/rsget.pl/RSGet/Wait.pm
==============================================================================
--- (empty file)
+++ toys/rsget.pl/RSGet/Wait.pm Sun Sep 13 13:21:18 2009
@@ -0,0 +1,78 @@
+package RSGet::Wait;
+
+use strict;
+use warnings;
+use RSGet::Tools;
+
+my %waiting;
+sub wait
+{
+ my $self = shift;
+ my $next_stage = shift;
+ my $wait = shift;
+ my $msg = shift || "???";
+ my $reason = shift || "wait";
+
+ $self->linedata( wait => $reason );
+
+ my $time = time;
+ delete $self->{wait_until_should};
+
+ my $rnd_wait = int rand ( 5 * 60 ) + 2 * 60;
+ if ( $wait > $rnd_wait + 1 * 60 ) {
+ $self->{wait_until_should} = $time + $wait;
+ $wait = $rnd_wait;
+ }
+ $wait = - $wait if $wait < 0;
+ $wait += int rand 10;
+
+ $self->{wait_next} = $next_stage;
+ $self->{wait_msg} = $msg;
+ $self->{wait_until} = $time + $wait;
+
+ my $id = 0;
+ ++$id while exists $waiting{ $id };
+ $waiting{ $id } = $self;
+}
+
+sub wait_finish
+{
+ my $self = shift;;
+
+ delete $self->{body};
+ $_ = undef;
+
+ $self->linedata();
+ my $func = $self->{wait_next};
+ &$func( $self );
+}
+
+sub wait_update
+{
+ my $time = time;
+
+ foreach my $id ( keys %waiting ) {
+ my $obj = $waiting{ $id };
+ my $left = $obj->{wait_until} - $time;
+ if ( $left <= 0 ) {
+ delete $waiting{ $id };
+ $obj->print( $obj->{wait_msg} . "; done waiting" );
+ wait_finish( $obj );
+ } elsif ( $obj->{_abort} ) {
+ delete $waiting{ $id };
+ $obj->abort();
+ } else {
+ if ( $obj->{wait_until_should} ) {
+ $obj->print( sprintf "%s; should wait %s, retrying in %s",
+ $obj->{wait_msg},
+ s2string( $obj->{wait_until_should} - $time),
+ s2string( $left ) );
+ } else {
+ $obj->print( $obj->{wait_msg} . "; waiting " . s2string( $left ) );
+ }
+ }
+ }
+ RSGet::Line::status( 'waiting' => scalar keys %waiting );
+}
+
+1;
More information about the pld-cvs-commit
mailing list