--- 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);
}