--- a/upload.pl Tue Nov 24 22:03:31 2015 +0100
+++ b/upload.pl Tue Nov 24 22:03:40 2015 +0100
@@ -1,4 +1,5 @@
#! /usr/bin/perl -T
+# FIXME: UPDATE {{
# Example .htaccess
# | Options -Indexes
# | <Files upload.pl>
@@ -19,6 +20,11 @@
# ScriptAlias /ud /home/ud/XXX/upload.pl
# Alias /d /home/ud/XXX/d/
# gesetzt werden.
+#
+# }}
+#
+
+# STATUS: Proof of Concept!
use 5.014;
use strict;
@@ -28,24 +34,34 @@
use CGI::Pretty;
use IO::File;
use File::Basename;
+use File::Path qw(remove_tree make_path);
+use File::Spec::Functions;
use File::MimeInfo qw(mimetype);
use Cwd qw(getcwd realpath);
use Digest::MD5 qw(md5_hex);
use OSSP::uuid;
-my $DIR = "d";
-my $DIR_URI = "/once/$DIR";
-sub human($);
-sub deletedir(@);
-sub confirm;
+sub human; # convert numbers to human readable format
+sub deletedir; # safely delete directories
+sub confirm; # ask for user confirmation (HTML)
+sub deslash; # cleanup a path name
+
+my $uuid = qr/[[:xdigit:]-]{36}/;
+my $hash = qr/[[:xdigit:]]{32}/;
+
+umask 077;
-delete @ENV{ grep /PATH/, keys %ENV };
-$ENV{PATH} = "/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin";
+# The working (var) directory gets passed to us via ONCE_VAR environment
+# FIXME: Should we allow the current directory as an alternative?
-$_ = dirname $DIR;
--d or mkdir $_ => 0750
- or die "Can't mkdir $_: $!\n";
+my $ONCE_VAR = do {
+ $ENV{ONCE_VAR} =~ /^(\/\S+)/;
+ die "Please define (correct) env ONCE_VAR\n"
+ if not defined $1;
+ $1;
+};
+
my @footer = (hr,
div(
@@ -56,7 +72,7 @@
"https://ssl.schlittermann.de/hg/anon-upload/file/once/"
} => "Scripting"
),
- " © 2010,2011 ",
+ " © 2010,2011,2015 ",
a({ -href => "http://www.schlittermann.de/" } => "Heiko Schlittermann"),
" © 2014 ",
a({ -href => "http://www.schlittermann.de/" } => "Matthias Förste")
@@ -65,65 +81,77 @@
MAIN: {
- # assuming download request
- if (request_uri =~ m|^\Q$DIR_URI\E/(.+)$|) {
+ # Download?
+ if ($ENV{PATH_INFO} =~ m{(?<path>(?<store>(?<view>/$hash|$uuid)/$uuid-\d+-.)/(?<base>.*))}) {
+ my $view = deslash realpath catfile $ONCE_VAR, $+{view};
+ my $store = deslash realpath catfile $ONCE_VAR, $+{store};
+ my $file = deslash realpath catfile $ONCE_VAR, $+{path};
+ my $base = $+{base};
- # assuming $DIR relative to cwd
- my $relative = $1;
- my $base = getcwd;
- my $absolute;
- unless ($absolute = realpath "$base/$DIR/$relative") {
- die "Can't realpath '$base/$DIR/$relative': $!"
- unless exists $!{ENOENT} and $!{ENOENT};
+ unless (-f $file) {
print header('text/plain', '404 Not found'), 'Not found';
exit 0;
}
- $absolute =~ m|^\Q$base/$DIR\E| or die "invalid path: [$absolute]";
- (my $dir = $relative) =~ s|/[^/]+$||;
- my $delete = $dir =~ /-d$/;
-
- confirm if ($delete and not defined param('confirmed'));
+ my $mimetype = mimetype($file);
+ confirm $base, $mimetype if $store =~ /-d$/ and not defined param('confirmed');
- open F, '<', $absolute or die "Can't open '<', '$absolute': $!";
- print header(-type => mimetype($absolute), -charset => 'UTF-8');
+ open my $f, '<', $file or die "Can't open <`$file`: $!\n";
+ remove_tree $1 if $store =~ m(^(/.*-d)$);
+ rmdir $1 if $view =~ m(^(/.*));
+
+ print header(-type => $mimetype, -charset => 'UTF-8');
if (request_method() ~~ [qw(GET POST)]) {
- my ($buf, $res);
- print $buf while $res = read F, $buf, 32 * 2**10;
- defined $res or die "Can't read: $!";
-
- deletedir $dir if $delete;
+ local $/ = \do{1 * 2**20}; # 1 MB Buffer
+ print while <$f>;
}
exit 0;
}
- # per view we have an own directory
+ # UPLOAD / VIEW request
+ # per view (user) we have an own directory
+
+ # pre condition checks
+ -d $ONCE_VAR or mkdir $ONCE_VAR => 0777
+ or die "Can't mkdir $ONCE_VAR: $! (your admin should have created it)\n";
+
+ -x -w $ONCE_VAR or
+ die "Can't write to $ONCE_VAR: $!\n";
- $ENV{REMOTE_USER} =~ /(.*)/;
- $_ = md5_hex($1);
- $DIR .= "/$_";
- $DIR_URI .= "/$_";
- -d $DIR
- or mkdir $DIR => 0750
- or die "Can't mkdir $DIR: $!\n";
+ my ($view, $user_dir) = do {
+ my ($v, $d);
+ if ($ENV{REMOTE_USER} =~ /^\s*(.+)\s*$/) {
+ $v = $1;
+ $d = md5_hex($1);
+ }
+ else {
+ tie $d => 'OSSP::uuid::tie', 'v4';
+ $v = 'anonymous';
+ }
+ $v, deslash catfile($ONCE_VAR, $d);
+ };
- if (param("delete") =~ /([-a-z\d]+-\d+-.)/i) {
- deletedir $1;
+ if (param('delete') =~ m{(?<store>(?<view>$uuid|$hash)/$uuid-\d+-./?)}) {
+ # FIXME: sanitization
+ my $store = deslash catfile $ONCE_VAR, $+{store};
+ my $view = deslash catfile $ONCE_VAR, $+{view};
+ remove_tree $1 if $store =~ m(^(/.*));
+ rmdir $1 if $view =~ m(^(/.*));
print redirect(-uri => url(-path_info => 1));
exit 0;
}
print header(-charset => "UTF-8"),
start_html(-title => "once"),
- h1 "Ansicht: $ENV{REMOTE_USER}";
+ h1 "Ansicht: $view";
# print Dump;
- if (length(my $file = param("upload"))) {
- my $days = param("expires");
+ if (length(my $file = param('upload'))) {
+ my $days = param('expires');
my ($delete, $expires);
- tie my $uuid => "OSSP::uuid::tie", "v4";
+ tie my $uuid => 'OSSP::uuid::tie', 'v4';
# sanitize expires
$days =~ /.*?([+-]?\d+).*/;
@@ -143,8 +171,8 @@
$filename =~ /(.*)/;
$filename = $1;
- my $dir = "$DIR/$uuid-$expires-$delete";
- mkdir $dir, 0750 or die "Can't mkdir $dir: $!\n";
+ my $dir = catfile($user_dir, "$uuid-$expires-$delete");
+ make_path($dir);
my $outfh = new IO::File ">$dir/$filename"
or die "Can't create $dir/$filename: $!\n";
print {$outfh} <$file>;
@@ -162,28 +190,25 @@
}
print hr;
- if (my @files = glob "$DIR/*-*/*") {
-
- #print "<pre>",
- #(map { "$_: $ENV{$_}\n" } sort keys %ENV),
- #"</pre>";
+ # List the current content
+ if (my @files = map { deslash $_ } glob "$user_dir/*-*/*") {
print p <<__;
- Der gültige Download-Link ist die Link-Adresse, die sich hinter
- dem Datei-Namen verbirgt. (Firefox: Rechte Maustaste, Link-Location).
- Nach Ablauf des <a href="http://de.wikipedia.org/wiki/Mindesthaltbarkeitsdatum">MHD</a>
- wird die Datei automatisch gelöscht.
+ <@files>
+Der gültige Download-Link ist die Link-Adresse, die sich hinter
+dem Datei-Namen verbirgt. (Firefox: Rechte Maustaste, Link-Location).
+Nach Ablauf des <a href="http://de.wikipedia.org/wiki/Mindesthaltbarkeitsdatum">MHD</a>
+wird die Datei automatisch gelöscht.
__
print start_table,
Tr(th { align => "left" }, [qw/Name Größe Hochgeladen Löschung/]);
- foreach (map { /(.*)/ } sort { -M $a <=> -M $b } glob "$DIR/*-*/*") {
+ foreach (map { /(.*)/ } sort { -M $a <=> -M $b } @files) {
my ($file, $dir) = fileparse($_);
- $dir = basename $dir;
+ $dir = substr $dir, length $ONCE_VAR; # make it relative to $ONCE_VAR
- # $dir =~ /(?<hash>\S+)-(?<expires>\d+)$/ or next;
- $dir =~ /(\S+)-(\d+)-(.)$/ or next;
+ $dir =~ /(\S+)-(\d+)-(.)\/?$/ or next;
my ($hash, $expires, $delete) = ($1, $2, $3);
if (${expires} <= time and $delete eq 'l') {
/(.*)/;
@@ -204,11 +229,11 @@
}
print Tr(
- td(a { href => "$DIR_URI/$dir/$file" }, $file),
+ td(a { href => "$ENV{PATH_INFO}/$dir$file" }, $file),
td({ align => "right" }, human((stat $_)[7])),
td(scalar localtime +(stat $_)[9]),
td($d),
- td(a({ href => "?delete=$dir" }, "remove"))
+ td(a({ href => "?delete=$dir" }, 'remove'))
);
}
@@ -231,17 +256,13 @@
end_html;
}
-sub deletedir(@) {
- for my $dir (@_) {
- if (-d "$DIR/$dir") {
- unlink map { /(.*)/ && $1 } glob("$DIR/$dir/*")
- or die "Can't unlink $DIR/$dir/*: $!\n";
- rmdir "$DIR/$dir" or die "Can't rmdir $DIR/$dir: $!\n";
- }
- }
+sub deletedir {
+ remove_tree
+ map { /^(\/.*)/ }
+ grep { /^\Q$ONCE_VAR\E/ } @_;
}
-sub human($) {
+sub human {
my $_ = shift;
my @units = qw(B K M G T);
while (length int > 3 and @units) {
@@ -253,12 +274,15 @@
return "$_$units[0]";
}
+sub deslash { $_[0] =~ s{/+}{/}gr }
+
sub confirm {
+ my ($base, $mimetype) = @_;
print header(-charset => "UTF-8"),
start_html(-title => "once"),
h1 "Download bestätigen";
print hr, p <<__;
- Die Datei, die Sie herunterladen möchten, wird nach Abschluß des
+ Die Datei `$base' ($mimetype), die Sie herunterladen möchten, wird nach Abschluß des
Downloads gelöscht. Virenscanner oder andere Programme, die den Link
möglicherweise automatisiert aufrufen, könnten eine versehentliche
Löschung der Datei auslösen. Bestätigen Sie deshalb bitte den Download