Finished image_dl.pm, updated conf and deps
* Закончен модуль image_dl.pm * Пример конфига приведён в соответствие с реалиями * Обновлён список зависимостей в cpanfile * fifo от image_dl добавлен в список .gitignore
This commit is contained in:
eleksir
3
.gitignore
vendored
3
.gitignore
vendored
@@ -1,2 +1,3 @@
|
||||
vendor_perl/**
|
||||
data/myapi.json
|
||||
data/myapi.json
|
||||
data/image_dl.fifo
|
||||
|
||||
3
cpanfile
3
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';
|
||||
requires 'Hailo';
|
||||
|
||||
@@ -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"
|
||||
}
|
||||
|
||||
160
lib/image_dl.pm
160
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;
|
||||
|
||||
10
myapi.psgi
10
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__
|
||||
|
||||
|
||||
Reference in New Issue
Block a user