# HG changeset patch
# User Heiko Schlittermann <hs@schlittermann.de>
# Date 1450654789 -3600
# Node ID 1f4bf7fe870e044d2cb2f83c8e8e0c362bcded1b
# Parent  e139241262c33bfa040cdeff7ef94f33d9b52b0e
[snapshot] Upload works…

The upload works for anonymous users. Several other things
need to be checked.

diff -r e139241262c3 -r 1f4bf7fe870e once.pl
--- a/once.pl	Mon Dec 21 00:39:06 2015 +0100
+++ b/once.pl	Mon Dec 21 00:39:49 2015 +0100
@@ -39,16 +39,19 @@
 use File::Spec::Functions;
 use File::MimeInfo qw(mimetype);
 use Cwd qw(getcwd realpath);
-use Digest::MD5 qw(md5_hex);
+use Digest::MD5 qw(md5_hex md5);
+use experimental qw(smartmatch lexical_topic);
 
 sub humanize;     # 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;
+sub gen_uuid;     # create a uniq identifier
+sub base62;
+sub md5_base62 { ... }
 
-my $uuid = qr/[[:xdigit:]-]{36}/;
-my $hash = qr/[[:xdigit:]]{32}/;
+my $rxVIEW = qr/[a-z\d]{6}-[a-z\d]+/i; # date-userhash
+my $rxFILE = qr/[a-z\d]{6}-[a-z\d]+-./i; # date-filehash-deletemode
 
 umask 077;
 
@@ -78,12 +81,21 @@
     )
 );
 
-MAIN: {
+exit main() if not caller;
+
+sub main {
 
     # Download?
+    # PATH_INFO is something like
+    # /once/hDOPzMJMY0p/3fLjYmbYlGk-1450284310-d/boot.dot
+    #       |-VIEW-----|                         |-BASE-|
+    #       |-STORE----------------------------|
+    # …     |-PATH--------------------------------------|
     if ($ENV{PATH_INFO} =~
-        m{(?<path>(?<store>(?<view>/$hash|$uuid)/$uuid-\d+-.)/(?<base>.*))})
+        m{/(?<path>(?<store>(?<view>$rxVIEW)/$rxFILE)/(?<base>.*))})
     {
+#        use Data::Dumper;
+#        die Dumper \%+;
         my $view  = deslash realpath catfile $ONCE_VAR, $+{view};
         my $store = deslash realpath catfile $ONCE_VAR, $+{store};
         my $file  = deslash realpath catfile $ONCE_VAR, $+{path};
@@ -111,7 +123,7 @@
 
     }
 
-    # UPLOAD / VIEW request
+    # Handle the UPLOAD / VIEW request
     # per view (user) we have an own directory
 
     # pre condition checks
@@ -123,19 +135,38 @@
       or die "Can't write to $ONCE_VAR: $!\n";
 
     my ($view, $user_dir) = do {
+        # view: display name
+        #       anonymous | hans | …
+        # user_dir: the directory name, becomes part of the
+        #           link, later
+        #       /var/lib/once/1AaIF9-1KF
+        #                            `--> base62 of a random value, may
+        #                            be shorter than 3 digits
+        #                     `-----> base62 of a unix time stamp,
+        #                     number of digits will be 6 for the
+        #                     forseeable future
+        # NOTE: if you change the generated user_dir string here, you may need
+        # to adapt the patterns $rxVIEW and $rxFILE at the beginning of
+        # the script.
+        #
         my ($v, $d);
         if ($ENV{REMOTE_USER} =~ /^\s*(.+)\s*$/) {
+            # Known users get a directory name based user name.
+            # Yes, if somebody can guess the user names, they can guess
+            # the directory names too. But they can't guess the
+            # completly randomly named files in there.
+            $d = join '-' => base62(time), md5_base62($1);
             $v = $1;
-            $d = md5_hex($1);
         }
         else {
-            $d = gen_uuid();
+            # Anonymous get an timestamp()-rand(1000) directory
+            $d = join '-' => base62(time), base62(rand(10_000));
             $v = 'anonymous';
         }
         $v, deslash catfile($ONCE_VAR, $d);
     };
 
-    if (param('delete') =~ m{(?<store>(?<view>$uuid|$hash)/$uuid-\d+-./?)}) {
+    if (param('delete') =~ m{(?<store>(?<view>$rxVIEW)/$rxFILE/?)}) {
 
         # FIXME: sanitization
         my $store = deslash catfile $ONCE_VAR, $+{store};
@@ -150,33 +181,33 @@
       start_html(-title => "once"),
       h1 "Ansicht: $view";
 
-    # print Dump;
-
+    # calculate the file name for the uploaded file
     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;
+        my ($delete, $expires, $days) = do {
+            my ($d, $e);
+            my $days = param('expires');
+            # sanitize expires
+            $days =~ /.*?([+-]?\d+).*/;
+            $days = $1 // 10;
+            $e = base62 time + $days * 86400;
 
-        $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
-        }
+            if ($days == 0) { $d = 'd' }       # at first [d]ownload
+            elsif ($days < 0) { $d = 'm' }     # only [m]anually
+            else { $d = 'e' }                  # if expired
+            ($d, $e, $days);
+        };
 
-        # sanitizing the filename
-        (my $filename = $file) =~ tr /\\/\//;
-        $filename =~ /(.*)/;
-        $filename = $1;
+        # sanitize the filename
+        my $filename = do {
+            $file =~ tr /\\/\//;
+            $file =~ /(.*)/;
+            $1;
+        };
 
-        my $dir = catfile($user_dir, "$uuid-$expires-$delete");
+        my $dir = catfile($user_dir, "$expires-$uuid-$delete");
         make_path($dir);
-        my $outfh = new IO::File ">$dir/$filename"
+        my $outfh = new IO::File "$dir/$filename", 'w'
           or die "Can't create $dir/$filename: $!\n";
         print {$outfh} <$file>;
 
@@ -187,7 +218,6 @@
               "rm -f \"$dir/$filename\"\n",
               "rmdir \"$dir\"\n";
             close $atfh;
-            system("cat /tmp/log");
         }
 
     }
@@ -212,9 +242,10 @@
             $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') {
+            # FIXME: use the rx* patterns from above
+            $dir =~ m{/(?<expires>[a-z\d]{6})-(?<hash>[a-z\d]+)-(?<delete>.)}i or next;
+            my ($hash, $expires, $delete) = @{+}{qw/hash expires delete/};
+            if (${expires} <= time and $delete eq 'e') {
                 /(.*)/;
                 unlink $_  or die "Can't unlik $_: $!\n";
                 rmdir $dir or die "Can't rmdir $dir: $!\n";
@@ -222,7 +253,7 @@
             }
 
             my $d;
-            if ($delete eq 'l') {
+            if ($delete eq 'e') {
                 $d = localtime ${expires};
             }
             elsif ($delete eq 'd') {
@@ -242,6 +273,7 @@
         }
 
         print end_table, hr;
+        return 0;
     }
 
     print start_multipart_form, start_table,
@@ -258,6 +290,8 @@
       end_multipart_form,
       @footer,
       end_html;
+
+      return 0;
 }
 
 sub deletedir {
@@ -303,7 +337,7 @@
 
 sub base62 {
     my $n = shift // $_;
-    die 'left integer precision' if $n == $n - 1 or $n == $n + 1;
+    die 'input is >MAXINT' if $n == $n - 1 or $n == $n + 1;
     state $digits = [0..9, 'a'..'z', 'A'..'Z'];
     state $base = @$digits;
     my @result;
@@ -316,9 +350,11 @@
     join '', @result;
 }
 
+
 sub gen_uuid {
-    open my $f, '/dev/random' or croak;
-    read $f, my $_, 64/8;
-    /^(.*)$/;
-    return join '-', map { base62 $_ } unpack 'Q*', $1;
+    #open my $f, '/dev/urandom' or croak;
+    #read $f, my($_), 128/8;
+    #/^(.*)$/;
+    #die join '-', map { base62 $_ } unpack 'Q*', $1;
+    return base62 int rand(2**64);
 }