# HG changeset patch # User Heiko Schlittermann # Date 1508254300 -7200 # Node ID a09a3ae04dcf5531a3310316dae4991c028c4a87 # Parent 75a06e057016ad903ad265e7267008fb089763cc Move to git.schlittermann.de diff -r 75a06e057016 -r a09a3ae04dcf Build.PL --- a/Build.PL Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -use Module::Build; - -Module::Build->new( - dist_name => 'once', - dist_version_from => 'lib/Once.pm', - dist_abstract => 'once downloader', - script_files => [qw(bin/once)], - share_dir => [qw(templates)], - PL_files => { - 'lib/version.PL' => 'templates/version.tt', - }, - requires => { - 'perl' => '5.0.18', - 'File::MimeInfo' => 0, - 'Template' => 0, - 'experimental' => 0, - }, -)->create_build_script; diff -r 75a06e057016 -r a09a3ae04dcf README --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/README Tue Oct 17 17:31:40 2017 +0200 @@ -0,0 +1,1 @@ +Move to git://git.schlittermann.de/user/heiko/once diff -r 75a06e057016 -r a09a3ae04dcf bin/once --- a/bin/once Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,393 +0,0 @@ -#! /usr/bin/perl -T -#line 2 -# 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 $Bin); -use File::Basename; -use File::Path qw(remove_tree make_path); -use File::Spec::Functions; -use File::ShareDir qw(dist_dir); -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); - -use lib "$Bin/../lib" =~ /(.*)/; -use Once; - -my $DIST = basename $0, '.pl'; - -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 = ( - PRE_PROCESS => 'version.tt', - INCLUDE_PATH => - [ (map { catfile($Bin, $_) } qw(templates templates.default) ), - #(map { catfile(dist_dir($DIST), $_) } qw(var templates.override templates)), - (map { catfile($RealBin, $_) } qw(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. (uid:$> gids:$)))\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 { - # FIXME: should we allow backslashes in filenames? It's totally legal for *nix, - # but may confuse win* users, for now we play safe and convert \ to _ - # OTOH, then we should convert other problematic chars too. - $file =~ tr /\\/\//; # convert \ to / - $file =~ s/.*\///; # poor man's basename - $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} = deslash "$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 sprintf "template: %s\nINCLUDE_PATH:\n%s\n", $tt->error(), - join "\n", map { "'$_'" } @{$TT_CONFIG{INCLUDE_PATH}}; - 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}; - - if (not -f $file) { - my $tt = Template->new(\%TT_CONFIG) - or die $Template::ERROR; - my %tt = ( file => { name => $base }); - - $tt->process('not-found.html', \%tt) or die $tt->error(); - 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 75a06e057016 -r a09a3ae04dcf configs/apache.conf --- a/configs/apache.conf Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -# This file should be placed as -# -> /etc/apache2/conf-available/once.conf -# and then you may use `a2enconf once` - - - SetEnv ONCE_VAR $var - SetEnv ONCE_LIB $lib - - # The directory where the files are stored. - # This directory needs to be r/w by the web server user - # (wwwrun, www-data, who ever), but it must not be - # accessible via HTTP(s) - - Require all denied - - - Action once-handler /once-handler/once virtual - ScriptAlias /once-handler/ $lib/bin/ - Alias $location/static $lib/static - - # Order of location blocks matters! - # We handle requests to our script, with the exception (see below) - # for …/static/… requests. These should be answered from a simple - # static directory for style sheets and similiar - - SetHandler once-handler - - - SetHandler none - - - - Require all granted - Allow from all - - - - Require all granted - Allow from all - Options ExecCGI FollowSymlinks - - - -Use ONCE /once /var/lib/once /usr/local/lib/once -UndefMacro ONCE diff -r 75a06e057016 -r a09a3ae04dcf d/dot.htaccess --- a/d/dot.htaccess Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6 +0,0 @@ -# needs AllowOverride AuthConfig Options -Options None Indexes ExecCGI FollowSymlinks - - Order allow,deny - allow from 127.0.0.1 - diff -r 75a06e057016 -r a09a3ae04dcf debdeps.control --- a/debdeps.control Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,12 +0,0 @@ -#!/usr/bin/equivs-build -Section: web -Priority: optional -Homepage: https://ssl.schlittermann.de/hg/anon-upload/file/once -Standards-Version: 3.9.2 -# grep -io '^use [^; ]*' upload.pl |while read x m; do dh-make-perl locate $m; done 2>&1|grep -Ev '^Using cached Contents'|sed 's/^.* is in //'|sed 's/ since [0-9.]\+$//' |sort -u -Depends: perl, libfile-mimeinfo-perl, libossp-uuid-perl -Package: ius-once-deps -Version: 1.0 -Description: dependencies for 'once' - 'once' is our 'one time download' skript; this package installs its - dependencies diff -r 75a06e057016 -r a09a3ae04dcf dot.htaccess --- a/dot.htaccess Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,17 +0,0 @@ -# needs AllowOverride AuthConfig Options -Options None Indexes ExecCGI FollowSymlinks - - Order deny,allow - deny from all - satisfy all - - - AuthType Basic - AuthName upload - Require valid-user - AuthUserFile /htpasswd - Order allow,deny - - - Order allow,deny - diff -r 75a06e057016 -r a09a3ae04dcf lib/Once.pm --- a/lib/Once.pm Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,13 +0,0 @@ -package Once; - -use strict; -use warnings; -use base 'Exporter'; - -our $VERSION = 0.0; -our @EXPORT_OK = qw(realpath); - -sub realpath { -} - -1; diff -r 75a06e057016 -r a09a3ae04dcf lib/version.PL --- a/lib/version.PL Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -#! /usr/bin/perl -my $outfile = shift; - -my $now = localtime; -chomp(my $version = `hg log -r . --template '{latesttag}-{latesttagdistance}-{node|short}\n'`); - -if (defined $outfile) { - open(STDOUT, '>', $_ = $outfile) or die "Can't open $_: $!\n"; -} - -print <<_; -[% # autogenerated at $now by $0 - # included automatically via PRE_PROCESS - vcs.version = "$version"; --%] -_ - -# zero timestamp does not work! Template/tpage will -# complain about "file not found" -utime 1, 1 => $outfile diff -r 75a06e057016 -r a09a3ae04dcf t/00-basic.t --- a/t/00-basic.t Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -use Test::More qw(no_plan); - -BEGIN { - use_ok 'Once', qw(realpath); -} - -is realpath('/'), '/' => 'realpath /'; diff -r 75a06e057016 -r a09a3ae04dcf templates/README --- a/templates/README Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -Do not overwrite the files here. If you want to modify something, -put your versions to "templates" in your lib directory. - - /usr/local/lib/once/templates/ for your modifications - /usr/local/lib/once/templates.default for default templates diff -r 75a06e057016 -r a09a3ae04dcf templates/confirm.html --- a/templates/confirm.html Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,11 +0,0 @@ -[% WRAPPER once.tt %] -

Download bestätigen

-
-Die Datei [% file.name | html %] ([% file.mimetype %]) -wird nach Abschluß des Downloads gelöscht werden - -
- - -
-[% END %] diff -r 75a06e057016 -r a09a3ae04dcf templates/inventory.html --- a/templates/inventory.html Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,48 +0,0 @@ -[% WRAPPER once.tt %] -

Ansicht: [% view %]

- -[%# The following part is the "inventory", that is, if there are any files %] -[% IF 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 MHD - wird die Datei automatisch gelöscht. -

- -
- - [%# Table for the files, our repository %] - - - - - [% FOREACH file IN files %] - - - - - - - - [% END # foreach %] -
NameGrößeHochgeladenLöschungAktion
[% file.name | html %][% file.size %][% date.format(file.uploaded, "%c") %][% file.removal.type %]remove
-
-[% END # files %] - -[%# Form for upload %] - -
- - - - - - - - - -
Dateiname:
Löschen in: Tagen (0: unmittelbar nach Download, -1: manuell)
-
- -[% END %] diff -r 75a06e057016 -r a09a3ae04dcf templates/not-found.html --- a/templates/not-found.html Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -[% WRAPPER once.tt %] -

Sorry

-Das File [% file.name | html %] existiert (nicht) mehr. -[% END %] diff -r 75a06e057016 -r a09a3ae04dcf templates/once.tt --- a/templates/once.tt Tue Oct 17 17:28:05 2017 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -Content-Type: text/html; charset=utf-8 - - -[%- - USE date; # for date formattting in inventory.html --%] - -Once - - - - - - -[% content %] - -
-
- [% vcs.version %] | Scripting: Matthias Förste, Heiko Schlittermann -
- - -[% - # vim:ft=html: -%]