diff -r 8de14266312f -r 1700cf720315 once.pl --- /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 +# | +# | AuthType Basic +# | AuthName upload +# | Require valid-user +# | AuthUserFile /home/heiko/public_html/.passwd +# | +# +# 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{(?(?(?/$hash|$uuid)/$uuid-\d+-.)/(?.*))}) + { + 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{(?(?$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 MHD +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; +}