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
files to repo and kicks metadata generation process.
But this data intended to help in package build script that prepares build environment, runs SlackBuilds, upload files
to repo and kicks metadata generation process.
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.
## Installation
In order to run this application, you need to "bootstrap" it - download and build
all required dependencies and libraries.
In order to run this application, you need to "bootstrap" it - download and build all required dependencies and
libraries.
You'll need "Development Tools" or similar group of packages, perl, perl-devel,
perl-local-lib, perl-app-cpanm, zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make.
You'll need "Development Tools" or similar group of packages, perl, perl-devel, perl-local-lib, perl-app-cpanm,
zlib-devel, openssl-devel, libdb4-devel (Berkeley DB devel), make.
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.
This application is tested and runs okay on Slackware64-14.2.
## How to run this?
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.
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?
Got something about this project? Make PR.
@@ -147,8 +154,8 @@ Got something about this project? Make PR.
## Who should i thank?
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?
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;
use 5.018;
use strict;
use warnings;
use vars qw/$VERSION/;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Carp;
use Encode qw (encode);
use JSON::XS;
use Slackmetarep::Conf qw(loadConf);
use Slackmetarep::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
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 ($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";
return ($status, $content, $msg);
return $status, $content, $msg;
}
open (my $jhandle, '<', $c->{buildinfo}->{$config}) or do {
$status = '500';
$msg = "Unable to open $c->{buildinfo}->{$config}; $OS_ERROR\n";
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 $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
unless (defined($readlen)) {
$status = '500';
unless (defined $readlen) {
$msg = "Unable to read $c->{buildinfo}->{$config}: $OS_ERROR";
carp '[FATA] ' . $msg;
return ($status, $content, $msg);
return '500', $content, $msg;
}
if ($len != $readlen) {
$status = '500';
$msg = "Size of $c->{buildinfo}->{$config} $len bytes but actually read $readlen bytes";
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 {
$status = '500';
# Make sure that we have utf-8 text here
$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";
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";
carp '[ERRO] ' . $msg;
return ($status, $content, $msg);
return $status, $content, $msg;
}
$json = JSON::XS->new->pretty->canonical->indent(1)->encode($j->{$package}) or do {
$status = '500';
# Use small indentation, just 1 space and default formatting
my $jq = JSON::XS->new->pretty->canonical->indent (1);
$msg = $jq->encode ($j->{$package}) or do {
$msg = "Unable to encode json.\n";
carp '[ERRO] ' . $msg;
return ($status, $content, $msg);
return '500', $content, $msg;
};
$status = '200';
$content = 'application/json';
$msg = $json;
return ($status, $content, $msg);
return '200', 'application/json', $msg;
}
1;

43
Slackmetarep/Conf.pm
View File

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

231
Slackmetarep/Metagen.pm
View File

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

42
Slackmetarep/Upload.pm
View File

@@ -1,5 +1,6 @@
package Slackmetarep::Upload;
use 5.018;
use strict;
use warnings;
use vars qw/$VERSION/;
@@ -7,16 +8,15 @@ use English qw( -no_match_vars );
use Carp;
use Fcntl;
use Slackmetarep::Conf qw(loadConf);
use Slackmetarep::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);
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 $len = shift; # expected data length (from client)
my $name = shift; # upload "dir" and filename
@@ -26,25 +26,30 @@ sub upload {
return ($status, $content, "No name supplied.\n") unless (defined $name);
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;
foreach my $uploaddir (keys(%{$c->{upload}->{dir}})) {
foreach my $uploaddir (keys %{$c->{upload}->{dir}}) {
if ($d eq $uploaddir) {
$match = 1;
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 (sysopen (my $FH, $name, O_CREAT|O_TRUNC|O_WRONLY)) {
if (sysopen my $FH, $name, O_CREAT|O_TRUNC|O_WRONLY) {
my $buf;
my $readlen = 0;
my $totalread = 0;
@@ -59,24 +64,29 @@ sub upload {
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)
unlink $name;
$buf = '';
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) {
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls)
unlink $name;
$buf = '';
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;
} while ($readlen == $buflen);
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls)
$buf = '';
if ($totalread != $len) {
($content, $msg) = ($content, "Content-Length does not match amount of recieved bytes.\n");
@@ -91,7 +101,7 @@ sub upload {
$msg = "Incorrect Content-Length\n";
}
return ($status, $content, $msg);
return $status, $content, $msg;
}
1;

7
confcheck.pl
View File

@@ -5,15 +5,18 @@ use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use JSON::XS;
use lib qw (./vendor_perl ./vendor_perl/lib/perl5);
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);
say $j->encode ($CONF); ## no critic (InputOutput::RequireCheckedSyscalls)

20
cpanfile
View File

@@ -1,8 +1,12 @@
requires 'Compress::Raw::Bzip2';
requires 'Compress::Raw::Zlib';
requires 'Exporter';
requires 'Fcntl';
requires 'JSON::XS';
requires 'POSIX';
requires 'Plack::Util';
requires 'local::lib';
## no critic (Modules::RequireVersionVar,Modules::RequireExplicitPackage,Modules::RequireEndWithOne)
## no critic (TestingAndDebugging::RequireUseStrict,TestingAndDebugging::RequireUseWarnings)
requires 'Compress::Raw::Bzip2', '==2.068';
requires 'Compress::Raw::Zlib', '==2.068';
requires 'Exporter', '==5.72';
requires 'Fcntl', '==1.13';
requires 'JSON::XS', '==4.03';
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)
use 5.018;
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
# my plugins
# Application modules
use lib qw (. ./vendor_perl ./vendor_perl/lib/perl5);
use Slackmetarep::Conf qw(loadConf);
use Slackmetarep::Upload qw(upload);
use Slackmetarep::Metagen qw(metagen);
use Slackmetarep::Buildinfo qw(buildinfo);
use Slackmetarep::Conf qw (LoadConf);
use Slackmetarep::Upload qw (Upload);
use Slackmetarep::Metagen qw (Metagen);
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};
# that is not module.
if ($CONF->{api}->{prefix} eq '/') {
$prefix = '';
}
my $app = sub { ## no critic (Modules::RequireEndWithOne)
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 (($upload !~ /\.\./xmsg) && ($upload =~ /^[_\-\+\/\.[:alnum:]]+$/xmsg)) {
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 {
$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") {
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") {
if (defined($env->{HTTP_REPO})) {
($status, $content, $msg) = buildinfo ($env->{HTTP_REPO});
($status, $content, $msg) = BuildInfo ($env->{HTTP_REPO});
}
}