eleksir/slackmetarep
0
Fork 0
Code Activity

Pin versions in cpanfile, fix coding style and cleanup a bit

Browse Source
This commit is contained in:
eleksir
2022-01-14 02:21:51 +03:00
parent c3f04b6c7f
commit 7575ad0378
8 changed files with 310 additions and 199 deletions
Download Patch File Download Diff File Expand all files Collapse all files

25
README.md
View File

@@ -85,19 +85,19 @@ Additional JSON-formatted metadata if required for buildinfo module to work. An
} }
``` ```
But this data intended to help in package build script that prepares build environment, runs SlackBuilds, upload But this data intended to help in package build script that prepares build environment, runs SlackBuilds, upload files
files to repo and kicks metadata generation process. to repo and kicks metadata generation process.
All metadata required and generated by this application very-very close to one found in AlienBob's All metadata required and generated by this application very-very close to one found in AlienBob's
[repositories](http://www.slackware.com/~alien/slackbuilds/), except no changelogs and rss are generated. [repositories](http://www.slackware.com/~alien/slackbuilds/), except no changelogs and rss are generated.
## Installation ## Installation
In order to run this application, you need to "bootstrap" it - download and build In order to run this application, you need to "bootstrap" it - download and build all required dependencies and
all required dependencies and libraries. libraries.
You'll need "Development Tools" or similar group of packages, perl, perl-devel, You'll need "Development Tools" or similar group of packages, perl, perl-devel, perl-local-lib, perl-app-cpanm,
perl-local-lib, perl-app-cpanm, zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make. zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make.
After installng required dependencies it is possible to run: After installng required dependencies it is possible to run:
@@ -107,6 +107,8 @@ bash bootstrap.sh
and all libraries should be downloaded, built, tested and installed. and all libraries should be downloaded, built, tested and installed.
This application is tested and runs okay on Slackware64-14.2.
## How to run this? ## How to run this?
Via [uWSGI](https://github.com/unbit/uwsgi). Via [uWSGI](https://github.com/unbit/uwsgi).
@@ -137,9 +139,14 @@ exec sudo -u apache -g apache /usr/bin/uwsgi \
``` ```
At least i use uwsgi for this. Starman suits well too and should work without any problems. You can also try At least i use uwsgi-2.0.19 for this. Starman suits well too and should work without any problems. You can also try
[Nginx UNIT](https://unit.nginx.org/), but it was totally not tested. [Nginx UNIT](https://unit.nginx.org/), but it was totally not tested.
As mentioned above this application tested on Slackware Linux 14.2 for x86_64. At least you'll need perl-AnyEvent,
perl-Coro, perl-Devel-StackTrace, perl-local-lib, cpanminus, perl-common-sense, perl-Guard, perl-EV,
perl-Canary-Stability, perl-event. You can get SlackBuilds for them on [SBo](https://slackbuilds.org/repository/14.2/).
After installing all these packages you'll be able to bootatrap and run slackmetarep.
## How to contribute? ## How to contribute?
Got something about this project? Make PR. Got something about this project? Make PR.
@@ -147,8 +154,8 @@ Got something about this project? Make PR.
## Who should i thank? ## Who should i thank?
Slackware mainatiners for their continous labour. Notably [AlienBob](https://docs.slackware.com/wiki:user:alienbob) and Slackware mainatiners for their continous labour. Notably [AlienBob](https://docs.slackware.com/wiki:user:alienbob) and
SBo team. [SBo team](https://slackbuilds.org/contributors/).
## What is missing here? ## What is missing here?
At least proper documentaion of metadata format generated by this particular application. At least proper documentaion of metadata format generated by this particular application. :)

77
Slackmetarep/Buildinfo.pm
View File

@@ -1,84 +1,95 @@
package Slackmetarep::Buildinfo; package Slackmetarep::Buildinfo;
use 5.018;
use strict; use strict;
use warnings; use warnings;
use vars qw/$VERSION/; use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Carp; use Carp;
use Encode qw (encode);
use JSON::XS; use JSON::XS;
use Slackmetarep::Conf qw(loadConf);
use Slackmetarep::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw(buildinfo); our @EXPORT_OK = qw (BuildInfo);
$VERSION = '1.0'; my $c = LoadConf ();
my $c = loadConf(); sub BuildInfo ($) {
sub buildinfo ($) {
my $repo = shift; my $repo = shift;
my ($status, $content, $msg) = ('400', 'text/plain', "Bad Request?\n"); my ($status, $content, $msg) = ('400', 'text/plain', "Bad Request?\n");
return ($status, $content, $msg) unless ($repo =~ /\//xmsg); # Request cosists of repo/package, so it must contain slash
unless ($repo =~ /\//xmsg) {
return $status, $content, $msg;
}
my ($config, $package) = split(/\//xms, $repo); my ($config, $package) = split /\//xms, $repo;
unless (defined($c->{buildinfo}->{$config})) { unless (defined $c->{buildinfo}->{$config}) {
$msg = "Config repo $config is not defined in config.\n"; $msg = "Config repo $config is not defined in config.\n";
return ($status, $content, $msg); return $status, $content, $msg;
} }
open (my $jhandle, '<', $c->{buildinfo}->{$config}) or do { open (my $jhandle, '<', $c->{buildinfo}->{$config}) or do {
$status = '500';
$msg = "Unable to open $c->{buildinfo}->{$config}; $OS_ERROR\n"; $msg = "Unable to open $c->{buildinfo}->{$config}; $OS_ERROR\n";
carp '[FATA] ' . $msg; carp '[FATA] ' . $msg;
return ($status, $content, $msg); return '500', $content, $msg;
}; };
my $len = (stat($c->{buildinfo}->{$config}))[7]; my $len = (stat $c->{buildinfo}->{$config})[7];
my $json; my $json;
my $readlen = read ($jhandle, $json, $len); # Use binmode in order to get read bytes (not chars!) from read()
binmode $jhandle;
my $readlen = read $jhandle, $json, $len;
close $jhandle; ## no critic (InputOutput::RequireCheckedSyscalls close $jhandle; ## no critic (InputOutput::RequireCheckedSyscalls
unless (defined($readlen)) { unless (defined $readlen) {
$status = '500';
$msg = "Unable to read $c->{buildinfo}->{$config}: $OS_ERROR"; $msg = "Unable to read $c->{buildinfo}->{$config}: $OS_ERROR";
carp '[FATA] ' . $msg; carp '[FATA] ' . $msg;
return ($status, $content, $msg); return '500', $content, $msg;
} }
if ($len != $readlen) { if ($len != $readlen) {
$status = '500';
$msg = "Size of $c->{buildinfo}->{$config} $len bytes but actually read $readlen bytes"; $msg = "Size of $c->{buildinfo}->{$config} $len bytes but actually read $readlen bytes";
carp '[FATA] ' . $msg; carp '[FATA] ' . $msg;
return ('500', $content, "Unable to read $c->{buildinfo}->{$config}\n"); return '500', $content, "Unable to read $c->{buildinfo}->{$config}\n";
} }
my $j = eval { decode_json($json) } or do { # Make sure that we have utf-8 text here
$status = '500'; $json = encode 'UTF-8', $json;
# Use relaxed decoder, we don't want to mess with human errors, right?
my $j = eval {
my $jq = JSON::XS->new->utf8->relaxed;
$jq->decode ($json);
} or do {
$msg = "Error during decoding $c->{buildinfo}->{$config}; $EVAL_ERROR\n"; $msg = "Error during decoding $c->{buildinfo}->{$config}; $EVAL_ERROR\n";
carp '[FATA] ' . $msg; carp '[FATA] ' . $msg;
return ($status, $content, $msg); return '500', $content, $msg;
}; };
unless (defined($j->{$package})) { $json = '';
unless (defined $j->{$package}) {
$msg = "$package is not defined in config for $config.\n"; $msg = "$package is not defined in config for $config.\n";
carp '[ERRO] ' . $msg; carp '[ERRO] ' . $msg;
return ($status, $content, $msg); return $status, $content, $msg;
} }
$json = JSON::XS->new->pretty->canonical->indent(1)->encode($j->{$package}) or do { # Use small indentation, just 1 space and default formatting
$status = '500'; my $jq = JSON::XS->new->pretty->canonical->indent (1);
$msg = $jq->encode ($j->{$package}) or do {
$msg = "Unable to encode json.\n"; $msg = "Unable to encode json.\n";
carp '[ERRO] ' . $msg; carp '[ERRO] ' . $msg;
return ($status, $content, $msg); return '500', $content, $msg;
}; };
$status = '200'; return '200', 'application/json', $msg;
$content = 'application/json';
$msg = $json;
return ($status, $content, $msg);
} }
1; 1;

43
Slackmetarep/Conf.pm
View File

@@ -1,5 +1,5 @@
package Slackmetarep::Conf; package Slackmetarep::Conf;
# loads config # Loads json formatted config
use 5.018; use 5.018;
use strict; use strict;
@@ -7,35 +7,44 @@ use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use Encode qw (encode);
use vars qw/$VERSION/;
use JSON::XS; use JSON::XS;
use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw(loadConf); our @EXPORT_OK = qw (LoadConf);
$VERSION = '1.0'; sub LoadConf {
my $file = 'data/config.json';
open my $FILEHANDLE, '<', $file || die "[FATA] No conf at $file: $OS_ERROR\n";
sub loadConf { # Use binmode in order to get amount of read bytes (not chars!) from read()
my $c = 'data/config.json'; binmode $FILEHANDLE;
open my $CH, '<', $c || die "[FATA] No conf at $c: $OS_ERROR\n"; my $len = (stat $file) [7];
my $len = (stat ($c)) [7];
my $json; my $json;
my $readlen = read $CH, $json, $len; my $readlen = read $FILEHANDLE, $json, $len;
$json = encode 'UTF-8', $json;
unless ($readlen) { unless (defined $readlen) {
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls close $FILEHANDLE; ## no critic (InputOutput::RequireCheckedSyscalls
die "[FATA] Unable to read $c: $OS_ERROR\n"; die "[FATA] Unable to read $file: $OS_ERROR\n";
} }
if ($readlen != $len) { if ($readlen != $len) {
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls close $FILEHANDLE; ## no critic (InputOutput::RequireCheckedSyscalls
die "[FATA] File $c is $len bytes on disk, but we read only $readlen bytes\n"; die "[FATA] File $file is $len bytes on disk, but we read only $readlen bytes\n";
} }
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls close $FILEHANDLE; ## no critic (InputOutput::RequireCheckedSyscalls
my $j = JSON::XS->new->utf8->relaxed; my $j = JSON::XS->new->utf8->relaxed;
return $j->decode ($json); my $config = eval { $j->decode ($json); };
unless (defined $config) {
die "[FATA] File $file does not contain a valid json data: $EVAL_ERROR\n";
}
return $config;
} }
1; 1;

231
Slackmetarep/Metagen.pm
View File

@@ -18,72 +18,89 @@
package Slackmetarep::Metagen; package Slackmetarep::Metagen;
use 5.018;
use warnings; use warnings;
use strict; use strict;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use vars qw/$VERSION/;
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use bytes ();
use Carp; use Carp;
use Fcntl; use Fcntl;
use Compress::Raw::Bzip2 qw (BZ_RUN_OK BZ_STREAM_END); use Compress::Raw::Bzip2 qw (BZ_RUN_OK BZ_STREAM_END);
use Compress::Raw::Zlib; use Compress::Raw::Zlib;
use POSIX qw (strftime); use POSIX qw (strftime);
use Slackmetarep::Conf qw(loadConf); use Slackmetarep::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw(metagen); our @EXPORT_OK = qw (Metagen);
$VERSION = '1.0'; sub Metagen ($);
sub __prettyFormattedDate (); # generates current date in pretty format
sub metagen($);
sub __pdate; # generates current date in pretty format
sub __trim ($); sub __trim ($);
sub __readfile($); sub __readFile ($);
sub __dirlist($); sub __dirList ($);
sub __writefile(@); sub __writeFile (@);
sub __bzdata($); sub __bzip2Data ($);
sub __gzdata($); sub __gzipData ($);
sub metagen ($) { sub Metagen ($) {
my $dir = shift; my $dir = shift;
my $c = loadConf(); my $c = LoadConf ();
$dir = $c->{metagen}->{$dir}; $dir = $c->{metagen}->{$dir};
unless (defined $dir || ($dir eq '')) { unless (defined $dir || ($dir eq '')) {
return ('400', 'text/plain', "No such repository\n"); return '400', 'text/plain', "No such repository\n";
}
my $dirlist = __dirList ($dir);
if (defined $dirlist->{error}) {
return '500', 'text/plain', $dirlist->{error};
} }
my $dirlist = __dirlist ($dir);
return ('500', 'text/plain', $dirlist->{error}) if (defined $dirlist->{error});
my @filelist = @{$dirlist->{dir}}; my @filelist = @{$dirlist->{dir}};
$dirlist = undef; $dirlist = undef;
# manifest # Generate Manifest.bz2
my $buf = ''; my $buf = '';
foreach my $filename (@filelist) { foreach my $filename (@filelist) {
if ($filename =~ /\.lst/xmsg) { if ($filename =~ /\.lst/xmsg) {
my $file = __readfile("$dir/$filename"); my $file = __readFile ("$dir/$filename");
return ('500', 'text/plain', $file->{error}) if (defined $file->{'error'});
if (defined $file->{'error'}) {
return '500', 'text/plain', $file->{error};
}
$buf .= __trim $file->{data}; $buf .= __trim $file->{data};
$buf .= "\n\n\n"; $buf .= "\n\n\n";
$file->{data} = ''; $file = undef;
$file->{data} = '';
$file = undef;
} }
} }
my $bzdata = __bzdata (\$buf); my $bzippedData = __bzip2Data (\$buf);
return ('500', 'text/plain', $bzdata->{error}) if (defined $bzdata->{error});
my $manifest = __writefile ("$dir/MANIFEST.bz2", \$bzdata->{data}); if (defined $bzippedData->{error}) {
return ('500', 'text/plain', $manifest->{error}) if (defined $manifest->{error}); return '500', 'text/plain', $bzippedData->{error};
}
$bzdata->{data} = ''; $bzdata = undef; my $manifest_bz2 = __writeFile ("$dir/MANIFEST.bz2", \$bzippedData->{data});
# checksums if (defined $manifest_bz2->{error}) {
return '500', 'text/plain', $manifest_bz2->{error};
}
$bzippedData->{data} = '';
$bzippedData = undef;
# Generate CHECKSUMS.md5 and CHECKSUMS.md5.gz
$buf = << 'MSG'; $buf = << 'MSG';
These are the MD5 message digests for the files in this directory. These are the MD5 message digests for the files in this directory.
If you want to test your files, use 'md5sum' and compare the values to If you want to test your files, use 'md5sum' and compare the values to
@@ -104,50 +121,88 @@ MSG
next if ($filename =~ /CHECKSUMS.md5.gz$/xmsg); next if ($filename =~ /CHECKSUMS.md5.gz$/xmsg);
if ($filename =~ /\.md5/xmsg) { if ($filename =~ /\.md5/xmsg) {
my $file = __readfile("$dir/$filename"); my $file = __readFile ("$dir/$filename");
return ('500', 'text/plain', $file->{error}) if (defined $file->{'error'});
if (defined $file->{'error'}) {
return '500', 'text/plain', $file->{error};
}
$buf .= $file->{data}; $buf .= $file->{data};
$file->{data} = ''; $file = undef;
$file->{data} = '';
$file = undef;
} }
} }
my $checksum = __writefile ("$dir/CHECKSUMS.md5", \$buf); my $checksum_md5_file = __writeFile ("$dir/CHECKSUMS.md5", \$buf);
return ('500', 'text/plain', $checksum->{error}) if (defined $checksum->{error});
if (defined $checksum_md5_file->{error}) {
return '500', 'text/plain', $checksum_md5_file->{error};
}
# Gzip CHECKSUM.md5 contents
my $gzippedBuf = __gzipData (\$buf);
if (defined $gzippedBuf->{error}) {
return '500', 'text/plain', $gzippedBuf->{error};
}
my $gzipchecksum = __gzdata(\$buf);
return ('500', 'text/plain', $gzipchecksum->{error}) if (defined $gzipchecksum->{error});
$buf = ''; $buf = '';
my $checksumgz = __writefile ("$dir/CHECKSUMS.md5.gz", \$gzipchecksum->{data}); my $checksum_md5_gz_file = __writeFile ("$dir/CHECKSUMS.md5.gz", \$gzippedBuf->{data});
return ('500', 'text/plain', $checksumgz->{error}) if (defined $checksumgz->{error});
$gzipchecksum->{data} = ''; $gzipchecksum = undef;
# packages if (defined $checksum_md5_gz_file->{error}) {
$buf = sprintf "PACKAGES.TXT; %s\n\n\n", __pdate; return '500', 'text/plain', $checksum_md5_gz_file->{error};
}
foreach my $filename (@filelist) { $gzippedBuf->{data} = '';
$gzippedBuf = undef;
# Generate PACKAGES.txt and PACKAGES.txt.gz
$buf = sprintf "PACKAGES.TXT; %s\n\n\n", __prettyFormattedDate ();
# At this point we have no need to preserve @filelist, we rather want to empty it
while (my $filename = shift @filelist) {
if ($filename =~ /\.meta/xmsg) { if ($filename =~ /\.meta/xmsg) {
my $file = __readfile("$dir/$filename"); my $file = __readFile ("$dir/$filename");
return ('500', 'text/plain', $file->{error}) if (defined $file->{'error'});
if (defined $file->{'error'}) {
return '500', 'text/plain', $file->{error};
}
$buf .= __trim ($file->{data}); $buf .= __trim ($file->{data});
$buf .= "\n\n"; $buf .= "\n\n";
$file->{data} = ''; $file = undef;
$file->{data} = '';
$file = undef;
} }
} }
my $packages = __writefile ("$dir/PACKAGES.TXT", \$buf); my $packages_txt_file = __writeFile ("$dir/PACKAGES.TXT", \$buf);
return ('500', 'text/plain', $packages->{error}) if (defined $packages->{error});
if (defined $packages_txt_file->{error}) {
return '500', 'text/plain', $packages_txt_file->{error};
}
$gzippedBuf = __gzipData (\$buf);
if (defined $gzippedBuf->{error}) {
return '500', 'text/plain', $gzippedBuf->{error};
}
my $gzippackages = __gzdata(\$buf);
return ('500', 'text/plain', $gzippackages->{error}) if (defined $gzippackages->{error});
$buf = ''; $buf = '';
my $packagesgz = __writefile ("$dir/PACKAGES.TXT.gz", \$gzippackages->{data}); my $packages_txt_gz_file = __writeFile ("$dir/PACKAGES.TXT.gz", \$gzippedBuf->{data});
return ('500', 'text/plain', $packagesgz->{error}) if (defined $packagesgz->{error});
$gzippackages->{data} = ''; $gzippackages = undef;
# filelist if (defined $packages_txt_gz_file->{error}) {
$buf = __pdate; return ('500', 'text/plain', $packages_txt_gz_file->{error});
}
$gzippedBuf->{data} = '';
$gzippedBuf = undef;
# Generate FILELIST.txt
$buf = __prettyFormattedDate;
$buf .= "\n\n"; $buf .= "\n\n";
$buf .= << 'BUFFER'; $buf .= << 'BUFFER';
Here is the file list for this directory, Here is the file list for this directory,
@@ -158,17 +213,19 @@ refresh the mirror.
BUFFER BUFFER
# dir listing is not actual, so we need to re-read it $dirlist = __dirList ($dir);
$#filelist = -1;
$dirlist = __dirlist ($dir); if (defined $dirlist->{error}) {
return ('500', 'text/plain', $dirlist->{error}) if (defined $dirlist->{error}); return '500', 'text/plain', $dirlist->{error};
}
@filelist = @{$dirlist->{dir}}; @filelist = @{$dirlist->{dir}};
$dirlist = undef; $dirlist = undef;
while (my $file = shift (@filelist)) { while (my $file = shift @filelist) {
my $filename = sprintf ('%s/%s', $dir, $file); my $filename = sprintf '%s/%s', $dir, $file;
my @stat = stat $filename; my @stat = stat $filename;
my @date = localtime ($stat[10]); my @date = localtime $stat[10];
$buf .= sprintf ( $buf .= sprintf (
"-rw-r--r-- %d root root % 8d %04d-%02d-%02d %02d:%02d ./%s\n", "-rw-r--r-- %d root root % 8d %04d-%02d-%02d %02d:%02d ./%s\n",
@@ -184,13 +241,18 @@ BUFFER
} }
$#filelist = -1; $#filelist = -1;
my $filelist = __writefile ("$dir/FILELIST.TXT", \$buf); my $filelist = __writeFile ("$dir/FILELIST.TXT", \$buf);
return ('500', 'text/plain', $filelist->{error}) if (defined $filelist->{error});
$buf = ''; if (defined $filelist->{error}) {
return ('200', 'text/plain', "Done\n"); return '500', 'text/plain', $filelist->{error};
} }
sub __pdate { $buf = '';
return '200', 'text/plain', "Done\n";
}
sub __prettyFormattedDate () {
my @time = gmtime(time); my @time = gmtime(time);
my @DAYOFWEEK = qw(Sun Mon Tue Wed Thu Fri Sat); my @DAYOFWEEK = qw(Sun Mon Tue Wed Thu Fri Sat);
my @MONTH = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Nov Dec); my @MONTH = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Nov Dec);
@@ -201,17 +263,17 @@ sub __trim ($) {
my $str = shift; my $str = shift;
while (substr ($str, 0, 1) =~ /^\s$/xms) { while (substr ($str, 0, 1) =~ /^\s$/xms) {
$str = substr ($str, 1); $str = substr $str, 1;
} }
while (substr ($str, -1, 1) =~ /^\s$/xms) { while (substr ($str, -1, 1) =~ /^\s$/xms) {
chop ($str); chop $str;
} }
return $str; return $str;
} }
sub __readfile ($) { sub __readFile ($) {
my $file = shift; my $file = shift;
my $ret; my $ret;
@@ -225,7 +287,7 @@ sub __readfile ($) {
binmode $FILEHANDLE; binmode $FILEHANDLE;
my $buf; my $buf;
my $len = (stat $file)[7]; my $len = (stat $file)[7];
my $readlen = read ($FILEHANDLE, $buf, $len); my $readlen = read $FILEHANDLE, $buf, $len;
close $FILEHANDLE; ## no critic (InputOutput::RequireCheckedSyscalls) close $FILEHANDLE; ## no critic (InputOutput::RequireCheckedSyscalls)
unless (defined $readlen) { unless (defined $readlen) {
@@ -246,7 +308,7 @@ sub __readfile ($) {
return $ret; return $ret;
} }
sub __writefile (@) { sub __writeFile (@) {
my $file = shift; my $file = shift;
my $dataref = shift; my $dataref = shift;
my $ret; my $ret;
@@ -260,10 +322,8 @@ sub __writefile (@) {
binmode $FILEHANDLE; binmode $FILEHANDLE;
use bytes; my $len = bytes::length ${$dataref};
my $len = length ${$dataref}; my $writelen = syswrite $FILEHANDLE, ${$dataref}, $len;
no bytes;
my $writelen = syswrite ($FILEHANDLE, ${$dataref}, $len);
close $FILEHANDLE; ## no critic (InputOutput::RequireCheckedSyscalls) close $FILEHANDLE; ## no critic (InputOutput::RequireCheckedSyscalls)
unless (defined $writelen) { unless (defined $writelen) {
@@ -284,7 +344,7 @@ sub __writefile (@) {
return $ret; return $ret;
} }
sub __dirlist ($) { sub __dirList ($) {
my $dir = shift; my $dir = shift;
my $res; my $res;
my @files; my @files;
@@ -307,10 +367,9 @@ sub __dirlist ($) {
return $res; return $res;
} }
sub __bzdata ($) { sub __bzip2Data ($) {
my $databufref = shift; my $databufref = shift;
my $ret; my $ret;
my $bzdata;
my $bz = Compress::Raw::Bzip2->new (1, 9, 0); my $bz = Compress::Raw::Bzip2->new (1, 9, 0);
unless (defined $bz) { unless (defined $bz) {
@@ -320,35 +379,36 @@ sub __bzdata ($) {
return $ret; return $ret;
} }
if ($bz->bzdeflate(${$databufref}, $bzdata) != BZ_RUN_OK) { if ($bz->bzdeflate (${$databufref}, $ret->{data}) != BZ_RUN_OK) {
my $msg = 'Unable to perofrm bzip2 compression'; my $msg = 'Unable to perofrm bzip2 compression';
carp "[FATA] $msg"; carp "[FATA] $msg";
delete ($ret->{data});
$ret->{error} = $msg; $ret->{error} = $msg;
return $ret; return $ret;
} }
if ($bz->bzflush($bzdata) != BZ_RUN_OK) { if ($bz->bzflush ($ret->{data}) != BZ_RUN_OK) {
my $msg = 'Unable to flush bz buffer'; my $msg = 'Unable to flush bz buffer';
carp "[FATA] $msg"; carp "[FATA] $msg";
delete ($ret->{data});
$ret->{error} = $msg; $ret->{error} = $msg;
return $ret; return $ret;
} }
if ($bz->bzclose($bzdata) != BZ_STREAM_END) { if ($bz->bzclose ($ret->{data}) != BZ_STREAM_END) {
my $msg = 'Unable to flush and close bz buffer'; my $msg = 'Unable to flush and close bz buffer';
carp "[FATA] $msg"; carp "[FATA] $msg";
delete ($ret->{data});
$ret->{error} = $msg; $ret->{error} = $msg;
return $ret; return $ret;
} }
$ret->{data} = $bzdata;
return $ret; return $ret;
} }
sub __gzdata ($) { sub __gzipData ($) {
my $databufref = shift; my $databufref = shift;
my $ret; my $ret;
my $gzdata;
my $gz = Compress::Raw::Zlib::Deflate->new ( my $gz = Compress::Raw::Zlib::Deflate->new (
-Level => Z_BEST_COMPRESSION, -Level => Z_BEST_COMPRESSION,
@@ -364,21 +424,22 @@ sub __gzdata ($) {
return $ret; return $ret;
} }
if ($gz->deflate(${$databufref}, $gzdata) != Z_OK) { if ($gz->deflate (${$databufref}, $ret->{data}) != Z_OK) {
my $msg = 'Unable to deflate'; my $msg = 'Unable to deflate';
carp "[FATA] $msg"; carp "[FATA] $msg";
delete ($ret->{data});
$ret->{error} = $msg; $ret->{error} = $msg;
return $ret; return $ret;
} }
if ($gz->flush($gzdata) != Z_OK) { if ($gz->flush ($ret->{data}) != Z_OK) {
my $msg = 'Unable to flush gz object'; my $msg = 'Unable to flush gz object';
carp "[FATA] $msg"; carp "[FATA] $msg";
delete ($ret->{data});
$ret->{error} = $msg; $ret->{error} = $msg;
return $ret; return $ret;
} }
$ret->{data} = $gzdata;
return $ret; return $ret;
} }

42
Slackmetarep/Upload.pm
View File

@@ -1,5 +1,6 @@
package Slackmetarep::Upload; package Slackmetarep::Upload;
use 5.018;
use strict; use strict;
use warnings; use warnings;
use vars qw/$VERSION/; use vars qw/$VERSION/;
@@ -7,16 +8,15 @@ use English qw( -no_match_vars );
use Carp; use Carp;
use Fcntl; use Fcntl;
use Slackmetarep::Conf qw(loadConf); use Slackmetarep::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
use Exporter qw (import); use Exporter qw (import);
our @EXPORT_OK = qw(upload); our @EXPORT_OK = qw (Upload);
$VERSION = '1.0'; my $c = LoadConf ();
my $c = loadConf (); sub Upload {
sub upload {
my $input = shift; # file descriptor with data being uploaded my $input = shift; # file descriptor with data being uploaded
my $len = shift; # expected data length (from client) my $len = shift; # expected data length (from client)
my $name = shift; # upload "dir" and filename my $name = shift; # upload "dir" and filename
@@ -26,25 +26,30 @@ sub upload {
return ($status, $content, "No name supplied.\n") unless (defined $name); return ($status, $content, "No name supplied.\n") unless (defined $name);
my $d; my $d;
($d, $name) = split (/\//xms, $name, 2); ($d, $name) = split /\//xms, $name, 2;
return ($status, $content, "Name does not match pattern.\n") unless ($name =~ /^[[:alnum:]_\-\+\.]+$/xmsg); unless ($name =~ /^[[:alnum:]_\-\+\.]+$/xmsg) {
return $status, $content, "Name does not match pattern.\n";
}
my $match; my $match;
foreach my $uploaddir (keys(%{$c->{upload}->{dir}})) { foreach my $uploaddir (keys %{$c->{upload}->{dir}}) {
if ($d eq $uploaddir) { if ($d eq $uploaddir) {
$match = 1; $match = 1;
last; last;
} }
} }
return ($status, $content, "Incorrect destination dir.\n") unless $match; # incorrect destination in url # Incorrect destination in url
unless ($match) {
return $status, $content, "Incorrect destination dir.\n";
}
$name = sprintf('%s/%s', $c->{upload}->{dir}->{$d}, $name); $name = sprintf '%s/%s', $c->{upload}->{dir}->{$d}, $name;
if ($len > 0) { if ($len > 0) {
if (sysopen (my $FH, $name, O_CREAT|O_TRUNC|O_WRONLY)) { if (sysopen my $FH, $name, O_CREAT|O_TRUNC|O_WRONLY) {
my $buf; my $buf;
my $readlen = 0; my $readlen = 0;
my $totalread = 0; my $totalread = 0;
@@ -59,24 +64,29 @@ sub upload {
my $written = syswrite $FH, $buf, $readlen; my $written = syswrite $FH, $buf, $readlen;
unless (defined($written)) { # out of space? # Not enough free space?
unless (defined $written) {
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls) close $FH; ## no critic (InputOutput::RequireCheckedSyscalls)
unlink $name; unlink $name;
$buf = '';
carp "[FATA] Unable to write to $name: $OS_ERROR"; carp "[FATA] Unable to write to $name: $OS_ERROR";
return ('500', $content, "An error has occured during upload: $OS_ERROR\n"); return '500', $content, "An error has occured during upload: $OS_ERROR\n";
} }
# Other error
if ($readlen != $written) { if ($readlen != $written) {
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls) close $FH; ## no critic (InputOutput::RequireCheckedSyscalls)
unlink $name; unlink $name;
$buf = '';
carp "[FATA] Must write $readlen bytes, but actualy wrote $written bytes to $name"; carp "[FATA] Must write $readlen bytes, but actualy wrote $written bytes to $name";
return ('500', $content, "An error has occured during upload: $OS_ERROR\n"); return '500', $content, "An error has occured during upload: $OS_ERROR\n";
} }
$totalread += $readlen; $totalread += $readlen;
} while ($readlen == $buflen); } while ($readlen == $buflen);
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls) close $FH; ## no critic (InputOutput::RequireCheckedSyscalls)
$buf = '';
if ($totalread != $len) { if ($totalread != $len) {
($content, $msg) = ($content, "Content-Length does not match amount of recieved bytes.\n"); ($content, $msg) = ($content, "Content-Length does not match amount of recieved bytes.\n");
@@ -91,7 +101,7 @@ sub upload {
$msg = "Incorrect Content-Length\n"; $msg = "Incorrect Content-Length\n";
} }
return ($status, $content, $msg); return $status, $content, $msg;
} }
1; 1;

7
confcheck.pl
View File

@@ -5,15 +5,18 @@ use strict;
use warnings; use warnings;
use utf8; use utf8;
use open qw (:std :utf8); use open qw (:std :utf8);
use English qw ( -no_match_vars ); use English qw ( -no_match_vars );
use JSON::XS; use JSON::XS;
use lib qw (./vendor_perl ./vendor_perl/lib/perl5); use lib qw (./vendor_perl ./vendor_perl/lib/perl5);
use Slackmetarep::Conf; use Slackmetarep::Conf;
use version; our $VERSION = qv(1.0); use version; our $VERSION = qw (1.0);
use Exporter qw (import);
my $CONF = loadConf(); my $CONF = LoadConf ();
my $j = JSON::XS->new->pretty->canonical->indent (1); my $j = JSON::XS->new->pretty->canonical->indent (1);
say $j->encode ($CONF); ## no critic (InputOutput::RequireCheckedSyscalls) say $j->encode ($CONF); ## no critic (InputOutput::RequireCheckedSyscalls)

20
cpanfile
View File

@@ -1,8 +1,12 @@
requires 'Compress::Raw::Bzip2'; ## no critic (Modules::RequireVersionVar,Modules::RequireExplicitPackage,Modules::RequireEndWithOne)
requires 'Compress::Raw::Zlib'; ## no critic (TestingAndDebugging::RequireUseStrict,TestingAndDebugging::RequireUseWarnings)
requires 'Exporter'; requires 'Compress::Raw::Bzip2', '==2.068';
requires 'Fcntl'; requires 'Compress::Raw::Zlib', '==2.068';
requires 'JSON::XS'; requires 'Exporter', '==5.72';
requires 'POSIX'; requires 'Fcntl', '==1.13';
requires 'Plack::Util'; requires 'JSON::XS', '==4.03';
requires 'local::lib'; requires 'POSIX', '==1.53_01';
requires 'Plack', '==1.0047';
# is a part of Plack distribution, unversioned
requires 'Plack::Util', '0';
requires 'local::lib', '==2.000024';

30
slackmetarep.psgi
View File

@@ -1,22 +1,28 @@
## no critic (Modules::RequireExplicitPackage) ## no critic (Modules::RequireExplicitPackage)
use 5.018;
use strict; use strict;
use warnings; use warnings;
use utf8;
use open qw (:std :utf8);
# my plugins # Application modules
use lib qw (. ./vendor_perl ./vendor_perl/lib/perl5); use lib qw (. ./vendor_perl ./vendor_perl/lib/perl5);
use Slackmetarep::Conf qw(loadConf); use Slackmetarep::Conf qw (LoadConf);
use Slackmetarep::Upload qw(upload); use Slackmetarep::Upload qw (Upload);
use Slackmetarep::Metagen qw(metagen); use Slackmetarep::Metagen qw (Metagen);
use Slackmetarep::Buildinfo qw(buildinfo); use Slackmetarep::Buildinfo qw (BuildInfo);
use version; our $VERSION = qv(1.0); use version; our $VERSION = qw (1.0);
use Exporter qw (import);
my $CONF = loadConf (); my $CONF = LoadConf ();
if ($CONF->{api}->{prefix} eq '/') { $CONF->{api}->{prefix} = ''; }
my $prefix = $CONF->{api}->{prefix}; my $prefix = $CONF->{api}->{prefix};
# that is not module. if ($CONF->{api}->{prefix} eq '/') {
$prefix = '';
}
my $app = sub { ## no critic (Modules::RequireEndWithOne) my $app = sub { ## no critic (Modules::RequireEndWithOne)
my $env = shift; my $env = shift;
@@ -31,7 +37,7 @@ my $app = sub { ## no critic (Modules::RequireEndWithOne)
if (defined($env->{HTTP_AUTH}) && ($env->{HTTP_AUTH} eq $CONF->{upload}->{auth})) { if (defined($env->{HTTP_AUTH}) && ($env->{HTTP_AUTH} eq $CONF->{upload}->{auth})) {
if (($upload !~ /\.\./xmsg) && ($upload =~ /^[_\-\+\/\.[:alnum:]]+$/xmsg)) { if (($upload !~ /\.\./xmsg) && ($upload =~ /^[_\-\+\/\.[:alnum:]]+$/xmsg)) {
if (defined($env->{CONTENT_LENGTH}) && ($env->{CONTENT_LENGTH} > 0)) { if (defined($env->{CONTENT_LENGTH}) && ($env->{CONTENT_LENGTH} > 0)) {
($status, $content, $msg) = upload ($env->{'psgi.input'}, $env->{CONTENT_LENGTH}, $upload); ($status, $content, $msg) = Upload ($env->{'psgi.input'}, $env->{CONTENT_LENGTH}, $upload);
} }
} else { } else {
$msg = "Something wrong with upload path.\n"; $msg = "Something wrong with upload path.\n";
@@ -41,11 +47,11 @@ my $app = sub { ## no critic (Modules::RequireEndWithOne)
} }
} elsif ($env->{PATH_INFO} eq "$prefix/metagen") { } elsif ($env->{PATH_INFO} eq "$prefix/metagen") {
if (defined($env->{HTTP_REPO})) { if (defined($env->{HTTP_REPO})) {
($status, $content, $msg) = metagen ($env->{HTTP_REPO}); ($status, $content, $msg) = Metagen ($env->{HTTP_REPO});
} }
} elsif ($env->{PATH_INFO} eq "$prefix/buildinfo") { } elsif ($env->{PATH_INFO} eq "$prefix/buildinfo") {
if (defined($env->{HTTP_REPO})) { if (defined($env->{HTTP_REPO})) {
($status, $content, $msg) = buildinfo ($env->{HTTP_REPO}); ($status, $content, $msg) = BuildInfo ($env->{HTTP_REPO});
} }
} }