once: comparison once.pl

equal deleted inserted replaced

-:e139241262c3
+:1f4bf7fe870e
 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 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;
-my $uuid = qr/[[:xdigit:]-]{36}/;
+sub md5_base62 { ... }
-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;
 # The working (var) directory gets passed to us via ONCE_VAR environment
 # FIXME: Should we allow the current directory as an alternative?
 " &copy; 2014 ",
 a({ -href => "http://www.schlittermann.de/" } => "Matthias Förste")
 )
 );
-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};
 my $base  = $+{base};
 }
 exit 0;
 }
-# UPLOAD / VIEW request
+# Handle the UPLOAD / VIEW request
 # per view (user) we have an own directory
 # pre condition checks
 -d $ONCE_VAR
 or mkdir $ONCE_VAR => 0777
 -x -w $ONCE_VAR
 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};
 my $view  = deslash catfile $ONCE_VAR, $+{view};
 remove_tree $1 if $store =~ m(^(/.*));
 print header(-charset => "UTF-8"),
 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, $days) = do {
-my ($delete, $expires);
+my ($d, $e);
-# sanitize expires
+my $days = param('expires');
-$days =~ /.*?([+-]?\d+).*/;
+# sanitize expires
-$days = defined $1 ? $1 : 10;
+$days =~ /.*?([+-]?\d+).*/;
+$days = $1 // 10;
-$expires = time + $days * 86400;
+$e = base62 time + $days * 86400;
-$delete  = 'l';                    # on file[l]ist
-if ($days == 0) {
+if ($days == 0) { $d = 'd' }       # at first [d]ownload
-$delete = 'd';                 # on first [d]ownload
+elsif ($days < 0) { $d = 'm' }     # only [m]anually
-}
+else { $d = 'e' }                  # if expired
-elsif ($days == -1) {
+($d, $e, $days);
-$delete = 'm';                 # only [m]anually
+};
-}
+# sanitize the filename
-# sanitizing the filename
+my $filename = do {
-(my $filename = $file) =~ tr /\\/\//;
+$file =~ tr /\\/\//;
-$filename =~ /(.*)/;
+$file =~ /(.*)/;
-$filename = $1;
+$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>;
 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;
 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;
+# FIXME: use the rx* patterns from above
-my ($hash, $expires, $delete) = ($1, $2, $3);
+$dir =~ m{/(?<expires>[a-z\d]{6})-(?<hash>[a-z\d]+)-(?<delete>.)}i or next;
-if (${expires} <= time and $delete eq 'l') {
+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";
 next;
 }
 my $d;
-if ($delete eq 'l') {
+if ($delete eq 'e') {
 $d = localtime ${expires};
 }
 elsif ($delete eq 'd') {
 $d = 'unmittelbar nach Download';
 }
 td(a({ href => "?delete=$dir" }, 'remove'))
 );
 }
 print end_table, hr;
+return 0;
 }
 print start_multipart_form, start_table,
 Tr(td("Dateiname: "),
 td(filefield(-name => "upload", -default => "nothing")),
 Tr(td(), td(submit(-value => "Hochladen")),),
 end_table,
 end_multipart_form,
 @footer,
 end_html;
+return 0;
 }
 sub deletedir {
 remove_tree
 map  { /^(\/.*)/ }
 exit 0;
 }
 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;
 for (;$n >= $base; $n = int($n/$base)) {
 }
 unshift @result, $digits->[$n];
 join '', @result;
 }
 sub gen_uuid {
-open my $f, '/dev/random' or croak;
+#open my $f, '/dev/urandom' or croak;
-read $f, my $_, 64/8;
+#read $f, my($_), 128/8;
-/^(.*)$/;
+#/^(.*)$/;
-return join '-', map { base62 $_ } unpack 'Q*', $1;
+#die join '-', map { base62 $_ } unpack 'Q*', $1;
-}
+return base62 int rand(2**64);
+}

changeset 55	1f4bf7fe870e
parent 54	e139241262c3
child 56	39c4a5f4ac33