diff --git a/README.md b/README.md index c700219..d9a4e2c 100644 --- a/README.md +++ b/README.md @@ -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. :) diff --git a/Slackmetarep/Buildinfo.pm b/Slackmetarep/Buildinfo.pm index 04f0d20..74fae83 100644 --- a/Slackmetarep/Buildinfo.pm +++ b/Slackmetarep/Buildinfo.pm @@ -1,84 +1,95 @@ package Slackmetarep::Buildinfo; +use 5.018; use strict; use warnings; -use vars qw/$VERSION/; -use English qw( -no_match_vars ); +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 Exporter qw(import); -our @EXPORT_OK = qw(buildinfo); +use Slackmetarep::Conf qw (LoadConf); -$VERSION = '1.0'; +use version; our $VERSION = qw (1.0); +use Exporter qw (import); +our @EXPORT_OK = qw (BuildInfo); -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; diff --git a/Slackmetarep/Conf.pm b/Slackmetarep/Conf.pm index c66c802..ccb4bde 100644 --- a/Slackmetarep/Conf.pm +++ b/Slackmetarep/Conf.pm @@ -1,41 +1,50 @@ package Slackmetarep::Conf; -# loads config +# Loads json formatted config use 5.018; use strict; use warnings; use utf8; -use open qw(:std :utf8); -use English qw( -no_match_vars ); - -use vars qw/$VERSION/; +use open qw (:std :utf8); +use English qw ( -no_match_vars ); +use Encode qw (encode); use JSON::XS; -use Exporter qw(import); -our @EXPORT_OK = qw(loadConf); +use version; our $VERSION = qw (1.0); +use Exporter qw (import); +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; diff --git a/Slackmetarep/Metagen.pm b/Slackmetarep/Metagen.pm index 69f8e0c..b4000c3 100644 --- a/Slackmetarep/Metagen.pm +++ b/Slackmetarep/Metagen.pm @@ -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 open qw (:std :utf8); +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::Bzip2 qw (BZ_RUN_OK BZ_STREAM_END); use Compress::Raw::Zlib; -use POSIX qw(strftime); +use POSIX qw (strftime); -use Slackmetarep::Conf qw(loadConf); +use Slackmetarep::Conf qw (LoadConf); -use Exporter qw(import); -our @EXPORT_OK = qw(metagen); +use version; our $VERSION = qw (1.0); +use Exporter qw (import); +our @EXPORT_OK = qw (Metagen); -$VERSION = '1.0'; +sub Metagen ($); +sub __prettyFormattedDate (); # generates current date in pretty format +sub __trim ($); +sub __readFile ($); +sub __dirList ($); +sub __writeFile (@); +sub __bzip2Data ($); +sub __gzipData ($); -sub metagen($); -sub __pdate; # generates current date in pretty format -sub __trim($); -sub __readfile($); -sub __dirlist($); -sub __writefile(@); -sub __bzdata($); -sub __gzdata($); - -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}); + my $filelist = __writeFile ("$dir/FILELIST.TXT", \$buf); + + if (defined $filelist->{error}) { + return '500', 'text/plain', $filelist->{error}; + } + $buf = ''; - return ('200', 'text/plain', "Done\n"); + + return '200', 'text/plain', "Done\n"; } -sub __pdate { +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; } diff --git a/Slackmetarep/Upload.pm b/Slackmetarep/Upload.pm index 75f6b91..66993c9 100644 --- a/Slackmetarep/Upload.pm +++ b/Slackmetarep/Upload.pm @@ -1,22 +1,22 @@ package Slackmetarep::Upload; +use 5.018; use strict; use warnings; use vars qw/$VERSION/; -use English qw( -no_match_vars ); +use English qw ( -no_match_vars ); use Carp; use Fcntl; -use Slackmetarep::Conf qw(loadConf); +use Slackmetarep::Conf qw (LoadConf); -use Exporter qw(import); -our @EXPORT_OK = qw(upload); +use version; our $VERSION = qw (1.0); +use Exporter qw (import); +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; @@ -55,28 +60,33 @@ sub upload { } do { - $readlen = $input->read($buf, $buflen); + $readlen = $input->read ($buf, $buflen); 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; diff --git a/confcheck.pl b/confcheck.pl index fb921b1..09fb5c6 100755 --- a/confcheck.pl +++ b/confcheck.pl @@ -4,17 +4,20 @@ use 5.018; use strict; use warnings; use utf8; -use open qw(:std :utf8); -use English qw( -no_match_vars ); +use open qw (:std :utf8); + +use English qw ( -no_match_vars ); 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 version; our $VERSION = qv(1.0); +use version; our $VERSION = qw (1.0); +use Exporter qw (import); -my $CONF = loadConf(); -my $j = JSON::XS->new->pretty->canonical->indent(1); +my $CONF = LoadConf (); +my $j = JSON::XS->new->pretty->canonical->indent (1); say $j->encode ($CONF); ## no critic (InputOutput::RequireCheckedSyscalls) # vim: set ft=perl noet ai ts=4 sw=4 sts=4: diff --git a/cpanfile b/cpanfile index ce40eff..54ede0b 100644 --- a/cpanfile +++ b/cpanfile @@ -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'; diff --git a/slackmetarep.psgi b/slackmetarep.psgi index bbcbce1..ec5efea 100644 --- a/slackmetarep.psgi +++ b/slackmetarep.psgi @@ -1,22 +1,28 @@ ## no critic (Modules::RequireExplicitPackage) +use 5.018; use strict; use warnings; +use utf8; +use open qw (:std :utf8); -# my plugins -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); +# 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 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}); } }