Fix parser, use regexes instead of substr, duh

* Check read() results where possible
* Use unbuffered writes for temp files
* Use vars instead of bare words as file handles
* Use $VERSION
* Coding style fixes
* Update of Readme.md

.gitignore

@@ -0,0 +1 @@
+vendor_perl/**

.perlcriticrc

@@ -0,0 +1,103 @@
+#!/usr/bin/env perlcritic
+severity    = 5
+verbose     = 8
+
+# minorify some of warnings that are not really critical
+[-InputOutput::RequireCheckedClose]
+# What can we handle in case of error?
+
+[-Modules::ProhibitExcessMainComplexity]
+# Noone cares
+
+[-Subroutines::ProhibitExcessComplexity]
+# Noone cares
+
+[-Subroutines::ProhibitExplicitReturnUndef]
+# But it's very handy sometimes!
+
+[-ValuesAndExpressions::ProhibitMagicNumbers]
+# this policy makes too much false positives
+
+[-RegularExpressions::RequireLineBoundaryMatching]
+# We use /m as needed
+
+[-RegularExpressions::RequireExtendedFormatting]
+# We do not use extended formatting of regex, they still not THAT complex
+
+[-RegularExpressions::RequireDotMatchAnything]
+# huh?
+
+[-RegularExpressions::ProhibitEscapedMetacharacters]
+# Looks like it pointless
+
+[-ControlStructures::ProhibitCascadingIfElse]
+# I like long if..else chains
+
+[-ControlStructures::ProhibitPostfixControls]
+# In short lines we can afford ourselves to use postfix controls
+# but of course we should avoid such constructions in long lines.
+
+[-Subroutines::ProhibitSubroutinePrototypes]
+# Contrary to  Perl::Critic  we consider prototypes as useful, even if
+# the compile-time checks of Perl are not perfect,  Perl may give some
+# hints.
+
+[-CodeLayout::RequireTidyCode]
+# Impossible to complete, because of on higher linting levels "## no critic..."
+# require be per-case on same line where critique is, but tidy align them
+# one line down.
+
+[-CodeLayout::ProhibitParensWithBuiltins]
+# duh...
+
+[-ValuesAndExpressions::ProhibitEmptyQuotes]
+# cause we consider following correct and useful:  my $var = '';
+# the recommended use of q{} looks too complex:     my $var = q{};
+
+[-ValuesAndExpressions::ProhibitNoisyQuotes]
+# Other people, other opinions: ","  is better readable than qw(,)
+
+[-BuiltinFunctions::ProhibitSleepViaSelect]
+# We do not wish to use too much external modules.
+# select undef, undef, undef, 0.25; # actually is okay if you add comment that
+# it is sleep for 0.25 seconds
+
+[-NamingConventions::Capitalization]
+# duh...
+# Noone cares, really
+
+[-ControlStructures::ProhibitUnlessBlocks]
+# They should not be too complex - only one condition should be checked,
+# that's all
+
+[-Miscellanea::ProhibitTies]
+# Just allow it. It's very handy stuff and extremely simple and safe enough to use.
+
+[-ValuesAndExpressions::RequireNumberSeparators]
+# Not really
+
+[-InputOutput::RequireBracedFileHandleWithPrint]
+# We prefer not to use braced file handles
+
+[-Documentation::PodSpelling]
+# It doesn't help, but emits annoying errors
+
+[Documentation::RequirePodSections]
+# Considering this as "soft" requirement. For modules that is (or will be)
+# stand-alone libs well formed documentation is highly desired.
+lib_sections    = NAME | VERSION | DESCRIPTION | AUTHOR | LICENSE AND COPYRIGHT
+
+[-ErrorHandling::RequireCheckingReturnValueOfEval]
+# In this app eval is not critical to error, so there is no need to check for it
+
+[-InputOutput::RequireBriefOpen]
+# Yes, i do!
+
+[-InputOutput::RequireCheckedSyscalls]
+# What can go wrong in "say"? what and how should i handle in this case?
+
+[-ControlStructures::ProhibitDeepNests]
+# Oh, really? Maybe you know better solution?
+
+[-Variables::ProhibitPunctuationVars]
+# I don't want use English here

README.md

@@ -18,8 +18,11 @@
 ## Как это работает?
 
 При обращении к сгенерённому урлу, апи вначале идёт на сайт, выкачивает
-видосик во временный каталог, отдаёт видосик клиенту и удаляет его из
-временного каталога. Есть встроенное ограничение на размер файла в 10Мб.
+видосик во временный каталог, отдаёт видосик клиенту. Есть встроенное
+ограничение на размер файла в 10Мб.
+
+N.B. Файлы из временного каталога автоматически не вычищаются. Получается
+своего рода "перманентный" кэш.
 
 ## Как это запустить?
 

cpanfile

@@ -1,3 +1,4 @@
-require HTTP::Tiny;
-require URI::URL;
-require URI::Escape;
+requires 'HTTP::Tiny';
+requires 'URI::URL';
+requires 'URI::Escape';
+requires 'Plack::Util';

joyproxy.pm

@@ -2,47 +2,62 @@ package joyproxy;
 
 use 5.018;
 use strict;
-use warnings "all";
+use warnings;
 use utf8;
-use open qw(:std :utf8);
+use open qw (:std :utf8);
 
+use Carp qw (carp);
+use Fcntl;
 use HTTP::Tiny;
 use URI::URL;
-use URI::Escape qw(uri_unescape);
+use URI::Escape qw (uri_unescape);
 
-use Exporter qw(import);
-use vars qw/$VERSION/;
-
-$VERSION = "1.0";
-our @EXPORT = qw(joyproxy joyurl);
-
-$| = 1;
+use Exporter qw (import);
+use version; our $VERSION = qw (1.1.1);
+our @EXPORT_OK = qw (joyproxy joyurl);
 
 sub joyproxy ($) {
 	my $str = shift;
-	chomp($str);
+	chomp $str;
 
-	return ('500', 'text/plain', 'This is not reactor video') if ($str !~ /^img[0-9]+\.reactor\.cc/);
+	# formal url check
+	if ($str !~ /^img\d+\.reactor\.cc/xmsg) {
+		return ('500', 'text/plain', 'This is not reactor video');
+	}
 
-	my ($file, $filesize) = __dlfunc("http://$str");
+	my ($file, $filesize) = __dlfunc ("http://$str");
 
-	if (defined($file)) {
+	if (defined $file) {
 		my $buf = '';
 
-		if (open(VID, '<', $file)) {
-			read(VID, $buf, $filesize);
-			close VID;
+		if (open my $VID, '<', $file) {
+			binmode $VID;
+			my $readlen = read ($VID, $buf, $filesize);
+			close $VID;
 
-			if ($file =~ /\.mp4/i) {
+			if (defined $readlen) {
+				if ($readlen != $filesize) {
+					carp "Unable to read $file readlen does not match filesize: $readlen vs $filesize";
+					return ('500', 'text/plain', "Unable to read file in temporary location\n");
+				}
+			} else {
+				carp "Unable to read $file: $!";
+				return ('500', 'text/plain', "Unable to read file in temporary location: $!\n");
+			}
+
+			if ($file =~ /\.mp4$/xmsgi) {
 				return ('200', 'video/mp4', $buf);
-			} elsif ($file =~ /\.webm/i) {
+			} elsif ($file =~ /\.webm$/xmsgi) {
 				return ('200', 'video/webm', $buf);
 			} else {
 				return ('200', 'video/mpeg', $buf);
 			}
 		} else {
-			unlink $file if (-f $file);
-			return ('500', 'text/plain', "Unable to open file in temporary loaction: $!\n");
+			if (-f $file) {
+				unlink $file;
+			}
+
+			return ('500', 'text/plain', "Unable to open file in temporary location: $!\n");
 		}
 	} else {
 		return ('500', 'text/plain', "Unable to get file from remote source!\n");
@@ -52,27 +67,28 @@ sub joyproxy ($) {
 sub joyurl (@) {
 	my $str  = shift;
 	my $host = shift;
-	$str = uri_unescape($str);
 
-	if (length($str) < 60) {
+	# TODO: handle error here
+	$str = uri_unescape $str;
+
+	if (length ($str) < 60) {
 		$str = '';
-	} else {
-		$str = substr($str, 14);
 	}
 
-	if ($str =~ /^img\d+\.reactor\.cc/) {
+	if ($str =~ /^joyurl=https?\:\/\/(img\d+\.reactor\.cc.+)/xmsg) {
+		my $string = $1;
 		# img1.reactor.cc/pics/post/webm/видосик.webm
-		my @url = split(/\//, $str);
+		my @url = split /\//msx, $string;
 
-		if (($url[3] eq 'webm' || $url[3] eq 'mp4') and
-		    ($url[4] =~ /\.webm$/ || $url[4] =~ /\.mp4$/)) {
+		if (($url[3] eq 'webm' || $url[3] eq 'mp4') &&
+			($url[4] =~ /\.webm$/xmsg || $url[4] =~ /\.mp4$/xmsg)) {
 			# we prefer mp4, right?, so
 			my $fname;
-			$fname = substr($url[4], 0, -4) if (substr($url[4], -4, 4) eq '.mp4');
-			$fname = substr($url[4], 0, -5) if (substr($url[4], -5, 6) eq '.webm');
+			$fname = substr ($url[4], 0, -5) if (substr ($url[4], -5, 6) eq '.webm');
+			$fname = substr ($url[4], 0, -4) if (substr ($url[4], -4, 4) eq '.mp4');
 
-			$str = sprintf(
-				"https://%s/joyproxy/%s/%s/%s/mp4/%s.mp4",
+			$string = sprintf (
+				'https://%s/joyproxy/%s/%s/%s/mp4/%s.mp4',
 				$host,
 				$url[0],
 				$url[1],
@@ -80,7 +96,7 @@ sub joyurl (@) {
 				$fname
 			);
 
-			$str = __urlencode($str);
+			$str = __urlencode ($string);
 		} else {
 			$str = '';
 		}
@@ -88,7 +104,16 @@ sub joyurl (@) {
 		$str = '';
 	}
 
-	my $msg = "<html>\n<body>\n<form method='get' action='joyurl'>\n<input type='text' name='joyurl' size=100 autofocus><br />\n<input type='submit' value='Post it!'' style='font-size:115%;'' />\n<br>$str\n</body>\n</html>\n";
+	my $msg = << "EOL";
+<html>
+<body>
+<form method='get' action='joyurl'>
+<input type='text' name='joyurl' size=100 autofocus><br />
+<input type='submit' value='Post it!' style='font-size:115%;' />
+<br>$str
+</body>
+</html>\n
+EOL
 
 	return ('200', 'text/html', $msg);
 }
@@ -97,71 +122,72 @@ sub __urlencode($) {
 	my $str = shift;
 	my $urlobj = url $str;
 	$str = $urlobj->as_string;
-	$urlobj = undef;
-	undef $urlobj;
+	$urlobj = '';
 	return $str;
 }
 
 sub __dlfunc($) {
 	my $url = shift;
 
-	if (! -d "/tmp/joyproxy") {
-		warn "no /tmp/joyproxy";
-		return (undef, undef) unless (mkdir("/tmp/joyproxy"));
+	unless (-d '/tmp/joyproxy') {
+		carp 'no /tmp/joyproxy';
+
+		unless (mkdir '/tmp/joyproxy') {
+			return (undef, undef);
+		}
 	}
 
-	my @tmparray = split(/\//, $url);
-	my $file = $tmparray[@tmparray - 1];
-	$#tmparray = -1; undef @tmparray;
-	$file = "/tmp/joyproxy/" . $file;
-	$url = __urlencode($url);
+	my @explodedurl = split /\//msx, $url;
+	my $file = $explodedurl[$#explodedurl]; ## no critic (Variables::RequireNegativeIndices)
+	$#explodedurl = -1; undef @explodedurl;
+	$file = '/tmp/joyproxy/' . $file;
+	$url = __urlencode ($url);
 
-	my $http = HTTP::Tiny->new(max_size => 10485760);
+	my $http = HTTP::Tiny->new (max_size => 10485760);
 
-	my $response = $http->get(
+	# use ->get because of ->mirror does not respect max_size
+	my $response = $http->get (
 		$url,
 		{
 			headers => {
-				"Accept" => '*/*',
-				"Accept-Encoding" => 'identity;q=1, *;q=0',
-				"Accept-Language" => 'ru-RU,ru;q=0.9,en-US;q=0.8,en;q=0.7',
-				"Range" => 'bytes=0-',
-				"Referer" => 'http://old.reactor.cc/all',
-				"User-Agent" => "Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/80.0.3987.116 Safari/537.36"
+				'Accept' => '*/*',
+				'Accept-Encoding' => 'identity;q=1, *;q=0',
+				'Accept-Language' => 'ru-RU,ru;q=0.9,en-US;q=0.8,en;q=0.7',
+				'Range' => 'bytes=0-',
+				'Referer' => 'http://old.reactor.cc/all',
+				'User-Agent' => 'Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/80.0.3987.116 Safari/537.36'
 			}
 		}
 	);
 
+	$http = '';
+
 	if ($response->{success}) {
 		my $filesize = 0;
 
-		open (FILE, '>', $file) or do {
-			$http = undef;
-			$response = undef;
+		sysopen (my $FILE, $file, O_CREAT|O_TRUNC|O_WRONLY) or do {
+			$response = '';
 			return (undef, undef);
 		};
 
-		binmode FILE;
+		binmode $FILE;
 
-		print (FILE $response->{content}) or do {
-			$http = undef;
-			$response = undef;
+		syswrite ($FILE, $response->{content}) or do {
+			close $FILE;
+			$response = '';
 			return (undef, undef);
 		};
 
-		close FILE;
-		$http = undef;
-		$response = undef;
-		$filesize = (stat($file))[7];
+		close $FILE;
+		$response = '';
+		$filesize = (stat $file )[7];
 		return ($file, $filesize);
 	} else {
-		$http = undef;
-		$response = undef;
+		$response = '';
 		return (undef, undef);
 	}
 }
 
-
 1;
 
 # vim: set ft=perl noet ai ts=4 sw=4 sts=4:

joyproxy.psgi

@@ -1,13 +1,14 @@
+#!/usr/bin/perl
+
 use 5.018;
 use strict;
-use warnings "all";
+use warnings;
 use utf8;
-use open qw(:std :utf8);
+use open qw (:std :utf8);
+use version; our $VERSION = qw (1.1.0);
 
-use lib qw(. ./vendor_perl/lib/perl5);
-use joyproxy qw(joyurl joyproxy);
-
-$| = 1;
+use lib qw (. ./vendor_perl/lib/perl5);
+use joyproxy qw (joyurl joyproxy);
 
 my $app = sub {
 	my $env = shift;
@@ -16,25 +17,23 @@ my $app = sub {
 	my $status = '404';
 	my $content = 'text/plain';
 
-	if ($env->{PATH_INFO} =~ /^\/joyproxy\/(.+)/) {
+	if ($env->{PATH_INFO} =~ /^\/joyproxy\/(.+)/xmsg) {
 		my $joyproxyurl = $1;
-		($status, $content, $msg) = ('400', $content, "Bad Request?\n");
+		($status, $msg) = ('400', "Bad Request?\n");
 
-		if (($joyproxyurl =~ /\.mp4/i) or ($joyproxyurl =~ /\.webm/i)) {
-			($status, $content, $msg) = joyproxy($joyproxyurl);
+		if (($joyproxyurl =~ /\.mp4$/xmsgi) or ($joyproxyurl =~ /\.webm$/xmsgi)) {
+			($status, $content, $msg) = joyproxy $joyproxyurl ;
 		}
 	}
 
-	if ($env->{PATH_INFO} =~ /^\/joyurl/) {
-		if (defined($env->{QUERY_STRING})) {
-			($status, $content, $msg) = joyurl($env->{QUERY_STRING}, $env->{HTTP_HOST});
-		} else {
-			($status, $content, $msg) = joyurl('', $env->{HTTP_HOST});
-		}
+	if ($env->{PATH_INFO} =~ /^\/joyurl/xmsg) {
+		my $querystring = $env->{QUERY_STRING} // '';
+
+		($status, $content, $msg) = joyurl ($querystring, $env->{HTTP_HOST});
 	}
 
 	use bytes;
-	my $length = length($msg);
+	my $length = length $msg;
 	no bytes;
 
 	return [

joyproxy.yaml

@@ -0,0 +1,17 @@
+uwsgi:
+  http-socket: 127.0.0.1:3081
+  socket-protocol: http
+  so-keepalive: 0
+  logformat: %(var.REMOTE_ADDR) %(var.REQUEST_METHOD) %(var.REQUEST_URI) %(status)
+  processes: 1
+  need-app: true
+  log-reopen: yes
+  reload-mercy: 5
+  buffer-size: 32768
+  die-on-term: true
+  pidfile: /run/joyproxy/joyproxy.pid
+  logto: /var/log/joyproxy/joyproxy.log
+  plugins: psgi
+  chdir: /var/lib/joyproxy
+  psgi: /var/lib/joyproxy/joyproxy.psgi
+  perl-local-lib: /var/lib/joyproxy/vendor_perl