diff -r 8de14266312f -r 1700cf720315 upload.pl
--- 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"
-        ),
-        " &copy; 2010,2011,2015 ",
-        a({ -href => "http://www.schlittermann.de/" } => "Heiko Schlittermann"),
-        " &copy; 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;
-}