# HG changeset patch # User Heiko Schlittermann # Date 1451421648 -3600 # Node ID 9b2e5de193c9217e6bb5687b2b865be569ff8076 # Parent f44ea3ef0634a307322e1e98acf61bd568065e09 Rework for Module::Build diff -r f44ea3ef0634 -r 9b2e5de193c9 .hgignore --- a/.hgignore Fri Dec 25 22:31:06 2015 +0100 +++ b/.hgignore Tue Dec 29 21:40:48 2015 +0100 @@ -1,3 +1,7 @@ -.htaccess -d/ -var/version.tt +^.htaccess +^var/version.tt +^blib/ +^Build$ +^_build/ +^MYMETA.json$ +^MYMETA.yml$ diff -r f44ea3ef0634 -r 9b2e5de193c9 Build.PL --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Build.PL Tue Dec 29 21:40:48 2015 +0100 @@ -0,0 +1,8 @@ +use Module::Build; + +Module::Build->new( + dist_name => 'once', + dist_version_from => 'lib/Once.pm', + dist_abstract => 'once downloader', + script_files => [qw(bin/once)], +)->create_build_script; diff -r f44ea3ef0634 -r 9b2e5de193c9 bin/once --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/bin/once Tue Dec 29 21:40:48 2015 +0100 @@ -0,0 +1,371 @@ +#! /usr/bin/perl -T +# FIXME: UPDATE {{ +# Example .htaccess +# | Options -Indexes +# | +# | AuthType Basic +# | AuthName upload +# | Require valid-user +# | AuthUserFile /home/heiko/public_html/.passwd +# | +# +# 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/once.pl +# Alias /d /home/ud/XXX/d/ +# gesetzt werden. +# +# }} +# +# +# Directory Structure +# $VAR/ (from ONCE_VAR environment) +# $userdir/ +# $uuid1-$timestamp-$removal_hint/$uploaded-file1 +# $uuid2-$timestamp-$removal_hint/$uploaded-file1 + + +# TODO: Security review! + +use 5.018; +use strict; +use warnings; +use IO::File; +use CGI qw(param upload header request_method url redirect); +use CGI::Carp qw(fatalsToBrowser); +use FindBin qw($RealBin); +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 md5); +use Template; +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; # create a uniq identifier +sub base62; +sub md5_base62 { ... } +sub untaint; + +# These to RX are used in several places. Do not change them. It's +# important that they do not include the ../ sequence (not even URL +# encoded!) +my $rxVIEW = qr/[a-z\d]{6}-[a-z\d]+/i; # date-userhash +my $rxFILE = qr/[a-z\d]{6}-[a-z\d]+-[dme]/i; # date-filehash-removalmode + +my $TT_CONFIG = + { INCLUDE_PATH => + [map { catfile($RealBin, $_) } qw(var templates.override templates)] }; + +umask 077; + +# The working (var) directory gets passed to us via ONCE_VAR environment +# FIXME: Should we allow the current directory as an alternative? + +die "Environment ONCE_VAR needs to be defined\n" + if not defined $ENV{ONCE_VAR}; +my $VAR = untaint($ENV{ONCE_VAR}, qr((^/.*))); + +exit main() if not caller; + +sub main { + + # Handle the UPLOAD / VIEW request + # per view (user) we have an own directory + + # Preconditions: $VAR needs to exist (it's the base directory + # for all R/W operations + -d $VAR + or mkdir $VAR => 0777 + or die "Can't mkdir $VAR: $! (your admin should have created it)\n"; + + -x -w $VAR + or die "Can't write to $VAR: $!\n"; + + # Check if the PATH_INFO looks like a download request. + # If so, we're done. + handle_download($ENV{PATH_INFO}) + and exit 0; + + handle_removal(param('delete')) + and exit 0; + + # Setup the essentials: view and user_dir + my ($view, $user_dir) = do { + + # view: display name + # anonymous | hans | … + # user_dir: the directory name, per view/user + # + # 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); + my $remote_user = defined $ENV{REMOTE_USER} + ? untaint $ENV{REMOTE_USER}, qr/(\w+)/ + : 'anonymous'; + $d = join '-' => base62(time), $remote_user; + $v = $remote_user; + $v, deslash catfile($VAR, $d); + }; + + # save the uploaded file + + if (length(my $file = param('upload'))) { + my $upload_fh = upload('upload'); + my $uuid = gen_uuid(); + my ($delete, $expires, $days) = do { + my ($d, $e); + my $days = param('expires') // 0; + + # sanitize expires + $days =~ /.*?([+-]?\d+).*/; + $days = $1 // 10; + $e = base62 time + $days * 86400; + + 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); + }; + + # sanitize the filename + my $filename = do { + $file =~ tr /\\/\//; + $file =~ /(.*)/; + $1; + }; + + my $dir = catfile($user_dir, "$expires-$uuid-$delete"); + make_path($dir); + { + my $outfh = new IO::File "$dir/$filename", 'w' + or die "Can't create $dir/$filename: $!\n"; + print {$outfh} <$upload_fh>; + } + + 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; + } + + } + + # create the view + my %tt = (view => $view); + my $tt = Template->new($TT_CONFIG) + or die $Template::ERROR; + + # List the current content + if (my @files = map { deslash $_ } glob "$user_dir/*-*/*") { + + foreach (map { /(.*)/ } sort { -M $a <=> -M $b } @files) { + + my %file; + + my ($file, $dir) = fileparse($_); + $dir = substr $dir, length $VAR; # make it relative to $VAR + + # FIXME: use the rx* patterns from above + $dir =~ m{/(?[a-z\d]{6})-(?[a-z\d]+)-(?.)}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"; + next; + } + + my $d; + if ($delete eq 'e') { + $d = localtime ${expires}; + } + elsif ($delete eq 'd') { + $d = 'unmittelbar nach Download'; + } + else { + $d = 'nur manuell'; + } + + $file{name} = $file; + $file{link} = "$ENV{PATH_INFO}/$dir$file"; + $file{size} = humanize -s $_; + $file{uploaded} = (stat _)[9]; + $file{removal}{type} = $d; + $file{removal}{link} = "?delete=$dir"; + + push @{ $tt{files} }, \%file; + } + + } + $tt->process('inventory.html', \%tt) or die $tt->error(); + return 0; +} + +sub deletedir { + remove_tree + map { /^(\/.*)/ } + grep { /^\Q$VAR\E/ } @_; +} + +sub humanize { + 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) = @_; + my %tt = ( + file => { + name => $base, + mimetype => $mimetype + } + ); + my $tt = Template->new($TT_CONFIG) + or die $Template::ERROR; + $tt->process('confirm.html' => \%tt); + exit 0; +} + +sub unbase62 { + my @digits = reverse split '', shift; + state $value = do { + my %value; + for ( + my ($symbol, $value) = (base62(0), 0) ; + length($symbol) == 1 ; + $symbol = base62 ++$value + ) + { + $value{$symbol} = $value; + } + \%value; + }; + state $base = scalar keys %$value; + + my $unbase62 = 0; + while (my ($p, $symbol) = each @digits) { + $unbase62 += $value->{$symbol} * $base**$p; + } + return $unbase62; +} + +sub base62 { + my $n = shift // $_; + 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)) { + my $mod = $n % $base; + unshift @result, $digits->[$mod]; + } + unshift @result, $digits->[$n]; + join '', @result; +} + +sub untaint { + my ($_, $rx) = (@_, qr((\w+))); + /$rx/; + die sprintf("%s:%s:%d: untaint('%s', %s): not defined\n", caller, $_, $rx) + if not defined $1; + return $1; +} + +sub gen_uuid { + + #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); +} + +# Download? +# PATH_INFO is something like +# /once/hDOPzMJMY0p/3fLjYmbYlGk-1450284310-d/boot.dot +# |-VIEW-----| |-BASE-| +# |-STORE----------------------------| +# … |-PATH--------------------------------------| +sub handle_download { + my $path_info = shift; + + $path_info =~ m{/(?(?(?$rxVIEW)/$rxFILE)/(?.*))} + or return 0; + + # use Data::Dumper; + # die Dumper \%+; + my $view = deslash realpath catfile $VAR, $+{view}; + my $store = deslash realpath catfile $VAR, $+{store}; + my $file = deslash realpath catfile $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>; + } + + return 1; +} + +sub handle_removal { + my $delete = shift; + + + return 0 + if not $delete =~ m{(?(?$rxVIEW)/$rxFILE/?)}; + + # FIXME: sanitization + my $store = untaint(deslash(catfile $VAR, $+{store}), qr{(\Q$VAR\E.+)}); + my $view = untaint(deslash(catfile $VAR, $+{view}), qr{(\Q$VAR\E.+)}); + + die "<< $store | $view ($+{store} $+{view}) >>"; + + remove_tree $store; + rmdir $view; + print redirect(-uri => url(-path_info => 1)); + + return 1; +} + diff -r f44ea3ef0634 -r 9b2e5de193c9 lib/Once.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/Once.pm Tue Dec 29 21:40:48 2015 +0100 @@ -0,0 +1,13 @@ +package Once; + +use strict; +use warnings; +use base 'Exporter'; + +our $VERSION = 0.0; +our @EXPORT_OK = qw(realpath); + +sub realpath { +} + +1; diff -r f44ea3ef0634 -r 9b2e5de193c9 once.pl --- a/once.pl Fri Dec 25 22:31:06 2015 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,356 +0,0 @@ -#! /usr/bin/perl -T -# FIXME: UPDATE {{ -# Example .htaccess -# | Options -Indexes -# | -# | AuthType Basic -# | AuthName upload -# | Require valid-user -# | AuthUserFile /home/heiko/public_html/.passwd -# | -# -# 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/once.pl -# Alias /d /home/ud/XXX/d/ -# gesetzt werden. -# -# }} -# - -# TODO: Security review! - -use 5.018; -use strict; -use warnings; -use IO::File; -use CGI qw(param upload); -use CGI::Carp qw(fatalsToBrowser); -use FindBin qw($RealBin); -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 md5); -use Template; -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; # create a uniq identifier -sub base62; -sub md5_base62 { ... } -sub untaint; - -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 - -my $TT_CONFIG = - { INCLUDE_PATH => - [map { catfile($RealBin, $_) } qw(var templates.override templates)] }; - -umask 077; - -# The working (var) directory gets passed to us via ONCE_VAR environment -# FIXME: Should we allow the current directory as an alternative? - -die "Environment ONCE_VAR needs to be defined\n" - if not defined $ENV{ONCE_VAR}; -my $VAR = untaint($ENV{ONCE_VAR}, qr((^/.*))); - -exit main() if not caller; - -sub main { - - # Handle the UPLOAD / VIEW request - # per view (user) we have an own directory - - # pre condition checks - -d $VAR - or mkdir $VAR => 0777 - or die "Can't mkdir $VAR: $! (your admin should have created it)\n"; - - -x -w $VAR - or die "Can't write to $VAR: $!\n"; - - # Download? - # PATH_INFO is something like - # /once/hDOPzMJMY0p/3fLjYmbYlGk-1450284310-d/boot.dot - # |-VIEW-----| |-BASE-| - # |-STORE----------------------------| - # … |-PATH--------------------------------------| - if ($ENV{PATH_INFO} =~ - m{/(?(?(?$rxVIEW)/$rxFILE)/(?.*))}) - { - # use Data::Dumper; - # die Dumper \%+; - my $view = deslash realpath catfile $VAR, $+{view}; - my $store = deslash realpath catfile $VAR, $+{store}; - my $file = deslash realpath catfile $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; - - } - - # Setup the essentials: view and user_dir - 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; - } - else { - # Anonymous get an timestamp()-rand(1000) directory - $d = join '-' => base62(time), base62(rand(10_000)); - $v = 'anonymous'; - } - $v, deslash catfile($VAR, $d); - }; - - # Handle the removal request and we're done - if (param('delete') =~ m{(?(?$rxVIEW)/$rxFILE/?)}) { - - # FIXME: sanitization - my $store = deslash catfile $VAR, $+{store}; - my $view = deslash catfile $VAR, $+{view}; - remove_tree $1 if $store =~ m(^(/.*)); - rmdir $1 if $view =~ m(^(/.*)); - print redirect(-uri => url(-path_info => 1)); - exit 0; - } - - # save the uploaded file - - if (length(my $file = param('upload'))) { - my $upload_fh = upload('upload'); - my $uuid = gen_uuid(); - my ($delete, $expires, $days) = do { - my ($d, $e); - my $days = param('expires') // 0; - - # sanitize expires - $days =~ /.*?([+-]?\d+).*/; - $days = $1 // 10; - $e = base62 time + $days * 86400; - - 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); - }; - - # sanitize the filename - my $filename = do { - $file =~ tr /\\/\//; - $file =~ /(.*)/; - $1; - }; - - my $dir = catfile($user_dir, "$expires-$uuid-$delete"); - make_path($dir); - { - my $outfh = new IO::File "$dir/$filename", 'w' - or die "Can't create $dir/$filename: $!\n"; - print {$outfh} <$upload_fh>; - } - - 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; - } - - } - - # create the view - my %tt = (view => $view); - my $tt = Template->new($TT_CONFIG) - or die $Template::ERROR; - - # List the current content - if (my @files = map { deslash $_ } glob "$user_dir/*-*/*") { - - foreach (map { /(.*)/ } sort { -M $a <=> -M $b } @files) { - - my %file; - - my ($file, $dir) = fileparse($_); - $dir = substr $dir, - length $VAR; # make it relative to $VAR - - # FIXME: use the rx* patterns from above - $dir =~ m{/(?[a-z\d]{6})-(?[a-z\d]+)-(?.)}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"; - next; - } - - my $d; - if ($delete eq 'e') { - $d = localtime ${expires}; - } - elsif ($delete eq 'd') { - $d = 'unmittelbar nach Download'; - } - else { - $d = 'nur manuell'; - } - - $file{name} = $file; - $file{link} = "$ENV{PATH_INFO}/$dir$file"; - $file{size} = humanize -s $_; - $file{uploaded} = (stat _)[9]; - $file{removal}{type} = $d; - $file{removal}{link} = "?delete=$dir"; - - push @{ $tt{files} }, \%file; - } - - } - $tt->process('inventory.html', \%tt) or die $tt->error(); - return 0; -} - -sub deletedir { - remove_tree - map { /^(\/.*)/ } - grep { /^\Q$VAR\E/ } @_; -} - -sub humanize { - 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) = @_; - my %tt = ( - file => { - name => $base, - mimetype => $mimetype - } - ); - my $tt = Template->new($TT_CONFIG) - or die $Template::ERROR; - $tt->process('confirm.html' => \%tt); - exit 0; -} - -sub unbase62 { - my @digits = reverse split '', shift; - state $value = do { - my %value; - for ( - my ($symbol, $value) = (base62(0), 0) ; - length($symbol) == 1 ; - $symbol = base62 ++$value - ) - { - $value{$symbol} = $value; - } - \%value; - }; - state $base = scalar keys %$value; - - my $unbase62 = 0; - while (my ($p, $symbol) = each @digits) { - $unbase62 += $value->{$symbol} * $base**$p; - } - return $unbase62; -} - -sub base62 { - my $n = shift // $_; - 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)) { - my $mod = $n % $base; - unshift @result, $digits->[$mod]; - } - unshift @result, $digits->[$n]; - join '', @result; -} - -sub untaint { - my ($_, $rx) = (@_, qr((\w+))); - /$rx/; - die sprintf("%s:%s:%d: untaint('%s', %s): not defined\n", caller, $_, $rx) - if not defined $1; - return $1; -} - -sub gen_uuid { - - #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); -} diff -r f44ea3ef0634 -r 9b2e5de193c9 t/00-basic.t --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/t/00-basic.t Tue Dec 29 21:40:48 2015 +0100 @@ -0,0 +1,7 @@ +use Test::More qw(no_plan); + +BEGIN { + use_ok 'Once', qw(realpath); +} + +is realpath('/'), '/' => 'realpath /';