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
+# | <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"
+        ),
+        " &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 {
+            $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;
+}