--- a/configs/apache.conf Tue Nov 24 22:20:26 2015 +0100
+++ b/configs/apache.conf Wed Dec 16 17:25:38 2015 +0100
@@ -6,7 +6,7 @@
# SentEnv may go into the <Directory>...</Directory>
SetEnv ONCE_VAR /var/lib/once/
# Action may go into <Location>...</Location>
-Action once-upload-handler /once-handler/upload.pl virtual
+Action once-upload-handler /once-handler/once.pl virtual
# Order of location blocks matters!
<Location "/once">
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/once.pl Wed Dec 16 17:25:38 2015 +0100
@@ -0,0 +1,323 @@
+#! /usr/bin/perl -T
+# FIXME: UPDATE {{
+# Example .htaccess
+# | Options -Indexes
+# | <Files upload.pl>
+# | AuthType Basic
+# | AuthName upload
+# | Require valid-user
+# | AuthUserFile /home/heiko/public_html/.passwd
+# | </Files>
+#
+# Je nach Permission-Lage kann es gut sein, daß das upload.d-Verzeichnis
+# mit der Hand angelegt werden muß und dem Webserver-Nutzer „geschenkt“
+# werden muß.
+#
+# Das Upload-Verzeichnis sollte natuerlich vor der Indizierung geschuetzt
+# werden - siehe Beispiel .htaccess.
+#
+# Eventuell in der Apache-Config sowas wie
+# ScriptAlias /ud /home/ud/XXX/upload.pl
+# Alias /d /home/ud/XXX/d/
+# gesetzt werden.
+#
+# }}
+#
+
+# STATUS: Proof of Concept!
+# NEEDS: Security review!
+
+use 5.014;
+use strict;
+use warnings;
+use CGI qw(:all *table);
+use CGI::Carp qw(fatalsToBrowser);
+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);
+
+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
+sub gen_uuid;
+
+my $uuid = qr/[[:xdigit:]-]{36}/;
+my $hash = qr/[[:xdigit:]]{32}/;
+
+umask 077;
+
+# The working (var) directory gets passed to us via ONCE_VAR environment
+# FIXME: Should we allow the current directory as an alternative?
+
+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(
+ { -align => "right" },
+ a(
+ {
+ -href =>
+ "https://ssl.schlittermann.de/hg/anon-upload/file/once/"
+ } => "Scripting"
+ ),
+ " © 2010,2011,2015 ",
+ a({ -href => "http://www.schlittermann.de/" } => "Heiko Schlittermann"),
+ " © 2014 ",
+ a({ -href => "http://www.schlittermann.de/" } => "Matthias Förste")
+ )
+);
+
+MAIN: {
+
+ # 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};
+
+ unless (-f $file) {
+ print header('text/plain', '404 Not found'), 'Not found';
+ exit 0;
+ }
+
+ my $mimetype = mimetype($file);
+ confirm $base, $mimetype
+ if $store =~ /-d$/ and not defined param('confirmed');
+
+ 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)]) {
+ local $/ = \do { 1 * 2**20 }; # 1 MB Buffer
+ print while <$f>;
+ }
+ exit 0;
+
+ }
+
+ # 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";
+
+ my ($view, $user_dir) = do {
+ my ($v, $d);
+ if ($ENV{REMOTE_USER} =~ /^\s*(.+)\s*$/) {
+ $v = $1;
+ $d = md5_hex($1);
+ }
+ else {
+ $d = gen_uuid();
+ $v = 'anonymous';
+ }
+ $v, deslash catfile($ONCE_VAR, $d);
+ };
+
+ 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: $view";
+
+ # print Dump;
+
+ if (length(my $file = param('upload'))) {
+ my $uuid = gen_uuid();
+ my $days = param('expires');
+ my ($delete, $expires);
+ # sanitize expires
+ $days =~ /.*?([+-]?\d+).*/;
+ $days = defined $1 ? $1 : 10;
+
+ $expires = time + $days * 86400;
+ $delete = 'l'; # on file[l]ist
+ if ($days == 0) {
+ $delete = 'd'; # on first [d]ownload
+ }
+ elsif ($days == -1) {
+ $delete = 'm'; # only [m]anually
+ }
+
+ # sanitizing the filename
+ (my $filename = $file) =~ tr /\\/\//;
+ $filename =~ /(.*)/;
+ $filename = $1;
+
+ 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>;
+
+ if (not $delete ~~ [qw(d m)]
+ and my $atfh = new IO::File("|at now + $days days"))
+ {
+ print {$atfh}
+ "rm -f \"$dir/$filename\"\n",
+ "rmdir \"$dir\"\n";
+ close $atfh;
+ system("cat /tmp/log");
+ }
+
+ }
+ print hr;
+
+ # List the current content
+ if (my @files = map { deslash $_ } glob "$user_dir/*-*/*") {
+
+ print p <<__;
+ <@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 } @files) {
+ my ($file, $dir) = fileparse($_);
+ $dir = substr $dir,
+ length $ONCE_VAR; # make it relative to $ONCE_VAR
+
+ $dir =~ /(\S+)-(\d+)-(.)\/?$/ or next;
+ my ($hash, $expires, $delete) = ($1, $2, $3);
+ if (${expires} <= time and $delete eq 'l') {
+ /(.*)/;
+ unlink $_ or die "Can't unlik $_: $!\n";
+ rmdir $dir or die "Can't rmdir $dir: $!\n";
+ next;
+ }
+
+ my $d;
+ if ($delete eq 'l') {
+ $d = localtime ${expires};
+ }
+ elsif ($delete eq 'd') {
+ $d = 'unmittelbar nach Download';
+ }
+ else {
+ $d = 'nur manuell';
+ }
+
+ print Tr(
+ 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'))
+ );
+ }
+
+ print end_table, hr;
+ }
+
+ print start_multipart_form, start_table,
+ Tr(td("Dateiname: "),
+ td(filefield(-name => "upload", -default => "nothing")),
+ ),
+ Tr(
+ td("Löschen in: "),
+ td(textfield(-name => "expires", -default => 0)),
+ td("Tagen (0: unmittelbar nach Download; -1: nur manuell)")
+ ),
+ Tr(td(), td(submit(-value => "Hochladen")),),
+ end_table,
+ end_multipart_form,
+ @footer,
+ end_html;
+}
+
+sub deletedir {
+ remove_tree
+ map { /^(\/.*)/ }
+ grep { /^\Q$ONCE_VAR\E/ } @_;
+}
+
+sub human {
+ my $_ = shift;
+ my @units = qw(B K M G T);
+ while (length int > 3 and @units) {
+ $_ = sprintf "%.1f" => $_ / 1024;
+ shift @units;
+ }
+ croak "filesize is too big (can't convert to human readable number)"
+ if !@units;
+ 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 `$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
+ per Knopfdruck.
+__
+ print start_form,
+ hidden('confirmed', 'yes'),
+ submit(-value => 'Bestätigung'),
+ end_form,
+ @footer,
+ end_html;
+ exit 0;
+}
+
+sub base62 {
+ my $n = shift;
+ state $digits = [0..9, 'a'..'z', 'A'..'Z'];
+ state $base = @$digits;
+ my @result;
+
+ for (;$n >= $base; $n = int($n/$base)) {
+ my $mod = $n % $base;
+ unshift @result, $digits->[$mod];
+ }
+ unshift @result, $digits->[$n];
+ join '', @result;
+}
+
+sub gen_uuid {
+ open my $f, '/dev/random' or croak;
+ read $f, my $_, 64/8;
+ /^(.*)$/;
+ return join '-', map { base62 $_ } unpack 'Q*', $1;
+}
--- a/upload.pl Tue Nov 24 22:20:26 2015 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,303 +0,0 @@
-#! /usr/bin/perl -T
-# FIXME: UPDATE {{
-# Example .htaccess
-# | Options -Indexes
-# | <Files upload.pl>
-# | AuthType Basic
-# | AuthName upload
-# | Require valid-user
-# | AuthUserFile /home/heiko/public_html/.passwd
-# | </Files>
-#
-# Je nach Permission-Lage kann es gut sein, daß das upload.d-Verzeichnis
-# mit der Hand angelegt werden muß und dem Webserver-Nutzer „geschenkt“
-# werden muß.
-#
-# Das Upload-Verzeichnis sollte natuerlich vor der Indizierung geschuetzt
-# werden - siehe Beispiel .htaccess.
-#
-# Eventuell in der Apache-Config sowas wie
-# ScriptAlias /ud /home/ud/XXX/upload.pl
-# Alias /d /home/ud/XXX/d/
-# gesetzt werden.
-#
-# }}
-#
-
-# STATUS: Proof of Concept!
-# NEEDS: Security review!
-
-use 5.014;
-use strict;
-use warnings;
-use CGI qw(:all *table);
-use CGI::Carp qw(fatalsToBrowser);
-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;
-
-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;
-
-# The working (var) directory gets passed to us via ONCE_VAR environment
-# FIXME: Should we allow the current directory as an alternative?
-
-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(
- { -align => "right" },
- a(
- {
- -href =>
- "https://ssl.schlittermann.de/hg/anon-upload/file/once/"
- } => "Scripting"
- ),
- " © 2010,2011,2015 ",
- a({ -href => "http://www.schlittermann.de/" } => "Heiko Schlittermann"),
- " © 2014 ",
- a({ -href => "http://www.schlittermann.de/" } => "Matthias Förste")
- )
-);
-
-MAIN: {
-
- # 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};
-
- unless (-f $file) {
- print header('text/plain', '404 Not found'), 'Not found';
- exit 0;
- }
-
- my $mimetype = mimetype($file);
- confirm $base, $mimetype
- if $store =~ /-d$/ and not defined param('confirmed');
-
- 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)]) {
- local $/ = \do { 1 * 2**20 }; # 1 MB Buffer
- print while <$f>;
- }
- exit 0;
-
- }
-
- # 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";
-
- 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') =~ 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: $view";
-
- # print Dump;
-
- if (length(my $file = param('upload'))) {
- my $days = param('expires');
- my ($delete, $expires);
- tie my $uuid => 'OSSP::uuid::tie', 'v4';
-
- # sanitize expires
- $days =~ /.*?([+-]?\d+).*/;
- $days = defined $1 ? $1 : 10;
-
- $expires = time + $days * 86400;
- $delete = 'l'; # on file[l]ist
- if ($days == 0) {
- $delete = 'd'; # on first [d]ownload
- }
- elsif ($days == -1) {
- $delete = 'm'; # only [m]anually
- }
-
- # sanitizing the filename
- (my $filename = $file) =~ tr /\\/\//;
- $filename =~ /(.*)/;
- $filename = $1;
-
- 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>;
-
- if (not $delete ~~ [qw(d m)]
- and my $atfh = new IO::File("|at now + $days days"))
- {
- print {$atfh}
- "rm -f \"$dir/$filename\"\n",
- "rmdir \"$dir\"\n";
- close $atfh;
- system("cat /tmp/log");
- }
-
- }
- print hr;
-
- # List the current content
- if (my @files = map { deslash $_ } glob "$user_dir/*-*/*") {
-
- print p <<__;
- <@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 } @files) {
- my ($file, $dir) = fileparse($_);
- $dir = substr $dir,
- length $ONCE_VAR; # make it relative to $ONCE_VAR
-
- $dir =~ /(\S+)-(\d+)-(.)\/?$/ or next;
- my ($hash, $expires, $delete) = ($1, $2, $3);
- if (${expires} <= time and $delete eq 'l') {
- /(.*)/;
- unlink $_ or die "Can't unlik $_: $!\n";
- rmdir $dir or die "Can't rmdir $dir: $!\n";
- next;
- }
-
- my $d;
- if ($delete eq 'l') {
- $d = localtime ${expires};
- }
- elsif ($delete eq 'd') {
- $d = 'unmittelbar nach Download';
- }
- else {
- $d = 'nur manuell';
- }
-
- print Tr(
- 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'))
- );
- }
-
- print end_table, hr;
- }
-
- print start_multipart_form, start_table,
- Tr(td("Dateiname: "),
- td(filefield(-name => "upload", -default => "nothing")),
- ),
- Tr(
- td("Löschen in: "),
- td(textfield(-name => "expires", -default => 0)),
- td("Tagen (0: unmittelbar nach Download; -1: nur manuell)")
- ),
- Tr(td(), td(submit(-value => "Hochladen")),),
- end_table,
- end_multipart_form,
- @footer,
- end_html;
-}
-
-sub deletedir {
- remove_tree
- map { /^(\/.*)/ }
- grep { /^\Q$ONCE_VAR\E/ } @_;
-}
-
-sub human {
- my $_ = shift;
- my @units = qw(B K M G T);
- while (length int > 3 and @units) {
- $_ = sprintf "%.1f" => $_ / 1024;
- shift @units;
- }
- croak "filesize is too big (can't convert to human readable number)"
- if !@units;
- 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 `$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
- per Knopfdruck.
-__
- print start_form,
- hidden('confirmed', 'yes'),
- submit(-value => 'Bestätigung'),
- end_form,
- @footer,
- end_html;
- exit 0;
-}