diff --git a/.gitignore b/.gitignore index 5a74c25..43baa2f 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ vendor_perl/** -data/myapi.json \ No newline at end of file +data/myapi.json +data/image_dl.fifo diff --git a/cpanfile b/cpanfile index 2196858..e5d0c90 100644 --- a/cpanfile +++ b/cpanfile @@ -2,6 +2,7 @@ requires 'local::lib'; requires 'Plack'; requires 'Net::Jabber::Bot'; requires 'Net::IRC'; +requires 'Net::LibIDN'; requires 'HTTP::Tiny'; requires 'IO::Socket::SSL'; -requires 'Hailo'; \ No newline at end of file +requires 'Hailo'; diff --git a/data/myapi.json.sample b/data/myapi.json.sample index 67f58da..11c63bb 100644 --- a/data/myapi.json.sample +++ b/data/myapi.json.sample @@ -3,12 +3,12 @@ "prefix" : "/api" }, "image_dl" : { - "dir" : "/home/eleksr/img-save", - "sleep" : 10 + "dir" : "/data/img-save", + "fifo" : "data/image_dl.fifo" }, "upload" : { "dir" : { - "mydir" : "/tmp/upload", + "mydir" : "/data/upload", }, "auth": "iliveoncemore" } diff --git a/lib/image_dl.pm b/lib/image_dl.pm index 75e4d6a..b3929ff 100644 --- a/lib/image_dl.pm +++ b/lib/image_dl.pm @@ -2,31 +2,47 @@ package image_dl; use strict; use warnings "all"; +use lib qw(./lib ./vendor_perl); +use Fcntl qw(O_RDONLY O_WRONLY); use HTTP::Tiny; -use Net::SSLeay; -use IO::Socket::SSL; use Image::Magick; +use POSIX qw(mkfifo); +use URI::URL; +use threads; +use threads::shared; use Exporter qw(import); use vars qw/$VERSION/; $VERSION = "1.0"; -our @EXPORT = qw(queue_image dl_thread); +our @EXPORT = qw(image_dl_queue image_dl_thread); +use conf; +my $c = loadConf(); +my @urls :shared; +my $ready :shared = 0; -sub queue_image (@) { - my $url = shift; - my $images = shift; - push @{$images}, $url; +unless (-p $c->{image_dl}->{fifo}) { + unless (mkfifo($c->{image_dl}->{fifo}, 0600)) { + die "Unable to create fifo $c->{image_dl}->{fifo} $!\n"; + } +} + +sub image_dl_queue ($) { + my $str = shift; + chomp($str); + sysopen (my $h, $c->{image_dl}->{fifo}, O_WRONLY) or return ('500', 'text/plain', "Unable to write url to queue: $!\n"); + syswrite $h, "$str\n", length("$str\n"); + close $h; return('200', 'text/plain', "Download queued\n"); } sub __urlencode($) { - my $url = shift; - my $urlobj = url $url; - $url = $urlobj->as_string; + my $str = shift; + my $urlobj = url $str; + $str = $urlobj->as_string; undef $urlobj; - return $url; + return $str; } sub __is_picture($) { @@ -40,6 +56,8 @@ sub __is_picture($) { undef $http; }; + return undef if (defined($@) && $@ ne ''); # means eval with error + if ($r->{'success'} and defined($r->{'headers'}->{'content-type'})) { if ($r->{'headers'}->{'content-type'} =~ /^image\/gif/) { $r = 'gif'; } elsif ($r->{'headers'}->{'content-type'} =~ /^image\/jpe?g/){ $r = 'jpeg';} @@ -51,85 +69,99 @@ sub __is_picture($) { $r = undef; } - undef $url; return $r; } + sub __dlfunc(@) { my $url = shift; my $file = shift; $url = __urlencode($url); +# it may timeout eval { my $http1 = HTTP::Tiny->new(); $http1->mirror($url, $file); undef $http1; }; - - eval { - if ($file =~ /(png|jpe?g|gif)$/i) { - my $im = Image::Magick->new(); - my $rename = 1; - my (undef, undef, undef, $format) = $im->Ping($file); - - if (defined($format)) { - $rename = 0 if (($format eq 'JPEG') and ($file =~ /jpe?g$/i)); - $rename = 0 if (($format eq 'GIF') and ($file =~ /gif$/i)); - $rename = 0 if (($format =~ /^PNG/) and ($file =~ /png$/i)); - rename $file, sprintf("%s.%s", $file, lc($format)) if ($rename == 1); - } - - undef $im; - undef $rename; - undef $format; - } - } - - #undef $url; - #undef $file; - #return; } +sub __image_dl_subthread { + $ready = 1; + threads::yield; -sub dl_thread (@) { - my $dir = shift; - my $sleep = shift; - threads->detach(); + while (sleep 3) { + while ( @urls > 0) { + my $str; +# lock will be removed when it goes out of scope, so make atifical scope just for shifting @urls + if (int(@urls) > 0) { + lock(@urls); # wait 'till it will be safe to grab lock on @urls + $str = shift(@urls); + } - while ( 1 ) { - if (@{main::images} > 0) { - my @pic = @{main::images}; - @{main::images} = -1; + next unless(defined($str)); + my $extension = __is_picture($str); - foreach my $url (@pic) { - my $extension = __is_picture($url); + if ($extension) { + my $savepath = $c->{image_dl}->{dir}; + mkdir ($savepath) unless (-d $savepath); + my $fname = $str; + $fname =~ s/[^\w!., -#]/_/g; + $savepath = sprintf("%s/%s.%s", $savepath, $fname, $extension); - if (defined($extension)) { - my $savepath = $dir; - mkdir ($savepath) unless (-d $savepath); - my $fname = $url; - $fname =~ s/[^\w!., -#]/_/g; - $savepath = sprintf("%s/%s.%s", $savepath, $fname, $extension); - - if ( (lc($url) =~ /\.(gif|jpe?g|png|webm|mp4)$/) and ($1 eq $extension) ) { - $savepath = $dir . "/" . $fname; - } - - __dlfunc($url, $savepath); - undef $savepath; - undef $fname; + if ( (lc($str) =~ /\.(gif|jpe?g|png|webm|mp4)$/) and ($1 eq $extension) ) { + $savepath = $c->{image_dl}->{dir} . "/" . $fname; } - undef $url; - undef $extension; + __dlfunc($str, $savepath); + undef $savepath; + undef $fname; } - @pic = -1; undef @pic; - } else { - sleep ($sleep); } } return; } +sub image_dl_thread { + open (my $h, "<", $c->{image_dl}->{fifo}) or die "Unable to open queue: $!\n"; + threads->create('__image_dl_subthread')->detach(); + do {} while (! $ready); + threads::yield; + + while (1) { + my $str = readline($h); + + if ((! defined($str)) || ($str eq "\n")) { + close $h; + open ($h, "<", $c->{image_dl}->{fifo}) or die "Unable to open queue: $!\n"; + next; + } + +# readline or <> from pipe can be funky: intead of 1 line, it _can_ return multiple lines + my @lines = split("\n", $str); + + while (@lines > 0) { + $str = pop(@lines); + next unless(defined($str)); + + if (substr($str, 0, 7) ne 'http://') { + if (substr($str, 0, 8) ne 'https://') { + next; + } + } + + chomp($str); +# wait 'till it will be safe to grab lock on @urls + lock(@urls); + push @urls, $str; + } + + close $h; + open ($h, "<", $c->{image_dl}->{fifo}) or die "Unable to open queue: $!\n"; + } + + close $h; +} + 1; diff --git a/myapi.psgi b/myapi.psgi index 31b45c6..9389ca5 100644 --- a/myapi.psgi +++ b/myapi.psgi @@ -2,21 +2,24 @@ use Data::Dumper; use strict; use warnings "all"; use diagnostics; -use JSON::PP; # my plugins -use lib "./lib"; +use lib qw(./lib ./vendor_perl); use conf; use ping; use utils; use easter_egg; use upload; +use image_dl; +use threads; my $CONF = loadConf(); if ($CONF->{api}->{prefix} eq '/') { $CONF->{api}->{prefix} = ''; } my $prefix = $CONF->{api}->{prefix}; +threads->create('image_dl_thread')->detach; + my $app = sub { my $env = shift; @@ -82,6 +85,8 @@ EOL } else { ($status, $content, $msg) = ('403', $content, "You're not allowed here. Fuck off.\n"); } + } elsif ($env->{PATH_INFO} eq "$prefix/image_dl") { + ($status, $content, $msg) = image_dl_queue($env->{HTTP_URL}); } @@ -92,6 +97,7 @@ EOL ]; }; + # vim: ft=perl noet ai ts=4 sw=4 sts=4: __END__