1 #! /usr/bin/perl -T

     2 # FIXME: UPDATE {{

     3 # Example .htaccess

     4 # | Options -Indexes

     5 # | <Files once.pl>

     6 # | AuthType Basic

     7 # | AuthName upload

     8 # | Require valid-user

     9 # | AuthUserFile /home/heiko/public_html/.passwd

    10 # | </Files>

    11 #

    12 # Je nach Permission-Lage kann es gut sein, daß das upload.d-Verzeichnis

    13 # mit der Hand angelegt werden muß und dem Webserver-Nutzer „geschenkt“

    14 # werden muß.

    15 #

    16 # Das Upload-Verzeichnis sollte natuerlich vor der Indizierung geschuetzt

    17 # werden - siehe Beispiel .htaccess.

    18 #

    19 # Eventuell in der Apache-Config sowas wie

    20 #   ScriptAlias /ud	    /home/ud/XXX/once.pl

    21 #   Alias	/d	    /home/ud/XXX/d/

    22 # gesetzt werden.

    23 #

    24 # }}

    25 #

    26 

    27 # TODO: Security review!

    28 

    29 use 5.018;

    30 use strict;

    31 use warnings;

    32 use IO::File;

    33 use CGI qw(param upload);

    34 use CGI::Carp qw(fatalsToBrowser);

    35 use FindBin qw($RealBin);

    36 use File::Basename;

    37 use File::Path qw(remove_tree make_path);

    38 use File::Spec::Functions;

    39 use File::MimeInfo qw(mimetype);

    40 use Cwd qw(getcwd realpath);

    41 use Digest::MD5 qw(md5_hex md5);

    42 use Template;

    43 use experimental qw(smartmatch lexical_topic);

    44 

    45 sub humanize;     # convert numbers to human readable format

    46 sub deletedir;    # safely delete directories

    47 sub confirm;      # ask for user confirmation (HTML)

    48 sub deslash;      # cleanup a path name

    49 sub gen_uuid;     # create a uniq identifier

    50 sub base62;

    51 sub md5_base62 { ... }

    52 sub untaint;

    53 

    54 my $rxVIEW = qr/[a-z\d]{6}-[a-z\d]+/i;      # date-userhash

    55 my $rxFILE = qr/[a-z\d]{6}-[a-z\d]+-./i;    # date-filehash-deletemode

    56 

    57 my $TT_CONFIG =

    58   { INCLUDE_PATH =>

    59       [map { catfile($RealBin, $_) } qw(var templates.override templates)] };

    60 

    61 umask 077;

    62 

    63 # The working (var) directory gets passed to us via ONCE_VAR environment

    64 # FIXME: Should we allow the current directory as an alternative?

    65 

    66 die "Environment ONCE_VAR needs to be defined\n"

    67   if not defined $ENV{ONCE_VAR};

    68 my $VAR = untaint($ENV{ONCE_VAR}, qr((^/.*)));

    69 

    70 exit main() if not caller;

    71 

    72 sub main {

    73 

    74     # Handle the UPLOAD / VIEW request

    75     # per view (user) we have an own directory

    76 

    77     # pre condition checks

    78     -d $VAR

    79       or mkdir $VAR => 0777

    80       or die "Can't mkdir $VAR: $! (your admin should have created it)\n";

    81 

    82     -x -w $VAR

    83       or die "Can't write to $VAR: $!\n";

    84 

    85     # Download?

    86     # PATH_INFO is something like

    87     # /once/hDOPzMJMY0p/3fLjYmbYlGk-1450284310-d/boot.dot

    88     #       |-VIEW-----|                         |-BASE-|

    89     #       |-STORE----------------------------|

    90     # …     |-PATH--------------------------------------|

    91     if ($ENV{PATH_INFO} =~

    92         m{/(?<path>(?<store>(?<view>$rxVIEW)/$rxFILE)/(?<base>.*))})

    93     {

    94         #        use Data::Dumper;

    95         #        die Dumper \%+;

    96         my $view  = deslash realpath catfile $VAR, $+{view};

    97         my $store = deslash realpath catfile $VAR, $+{store};

    98         my $file  = deslash realpath catfile $VAR, $+{path};

    99         my $base  = $+{base};

   100 

   101         unless (-f $file) {

   102             print header('text/plain', '404 Not found'), 'Not found';

   103             exit 0;

   104         }

   105 

   106         my $mimetype = mimetype($file);

   107         confirm $base, $mimetype

   108           if $store =~ /-d$/ and not defined param('confirmed');

   109 

   110         open my $f, '<', $file or die "Can't open <`$file`: $!\n";

   111         remove_tree $1 if $store =~ m(^(/.*-d)$);

   112         rmdir $1 if $view =~ m(^(/.*));

   113 

   114         print header(-type => $mimetype, -charset => 'UTF-8');

   115         if (request_method() ~~ [qw(GET POST)]) {

   116             local $/ = \do { 1 * 2**20 };    # 1 MB Buffer

   117             print while <$f>;

   118         }

   119         exit 0;

   120 

   121     }

   122 

   123     # Setup the essentials: view and user_dir

   124     my ($view, $user_dir) = do {

   125 

   126         # view: display name

   127         #       anonymous | hans | …

   128         # user_dir: the directory name, becomes part of the

   129         #           link, later

   130         #       /var/lib/once/1AaIF9-1KF

   131         #                            `--> base62 of a random value, may

   132         #                            be shorter than 3 digits

   133         #                     `-----> base62 of a unix time stamp,

   134         #                     number of digits will be 6 for the

   135         #                     forseeable future

   136         # NOTE: if you change the generated user_dir string here, you may need

   137         # to adapt the patterns $rxVIEW and $rxFILE at the beginning of

   138         # the script.

   139         #

   140         my ($v, $d);

   141         if ($ENV{REMOTE_USER} =~ /^\s*(.+)\s*$/) {

   142 

   143             # Known users get a directory name based user name.

   144             # Yes, if somebody can guess the user names, they can guess

   145             # the directory names too. But they can't guess the

   146             # completly randomly named files in there.

   147             $d = join '-' => base62(time), md5_base62($1);

   148             $v = $1;

   149         }

   150         else {

   151             # Anonymous get an timestamp()-rand(1000) directory

   152             $d = join '-' => base62(time), base62(rand(10_000));

   153             $v = 'anonymous';

   154         }

   155         $v, deslash catfile($VAR, $d);

   156     };

   157 

   158     # Handle the removal request and we're done

   159     if (param('delete') =~ m{(?<store>(?<view>$rxVIEW)/$rxFILE/?)}) {

   160 

   161         # FIXME: sanitization

   162         my $store = deslash catfile $VAR, $+{store};

   163         my $view  = deslash catfile $VAR, $+{view};

   164         remove_tree $1 if $store =~ m(^(/.*));

   165         rmdir $1 if $view =~ m(^(/.*));

   166         print redirect(-uri => url(-path_info => 1));

   167         exit 0;

   168     }

   169 

   170     # save the uploaded file

   171 

   172     if (length(my $file = param('upload'))) {

   173         my $upload_fh = upload('upload');

   174         my $uuid      = gen_uuid();

   175         my ($delete, $expires, $days) = do {

   176             my ($d, $e);

   177             my $days = param('expires') // 0;

   178 

   179             # sanitize expires

   180             $days =~ /.*?([+-]?\d+).*/;

   181             $days = $1 // 10;

   182             $e = base62 time + $days * 86400;

   183 

   184             if    ($days == 0) { $d = 'd' }    # at first [d]ownload

   185             elsif ($days < 0)  { $d = 'm' }    # only [m]anually

   186             else               { $d = 'e' }    # if expired

   187             ($d, $e, $days);

   188         };

   189 

   190         # sanitize the filename

   191         my $filename = do {

   192             $file =~ tr /\\/\//;

   193             $file =~ /(.*)/;

   194             $1;

   195         };

   196 

   197         my $dir = catfile($user_dir, "$expires-$uuid-$delete");

   198         make_path($dir);

   199         {

   200             my $outfh = new IO::File "$dir/$filename", 'w'

   201               or die "Can't create $dir/$filename: $!\n";

   202             print {$outfh} <$upload_fh>;

   203         }

   204 

   205         if (not $delete ~~ [qw(d m)]

   206             and my $atfh = new IO::File("|at now + $days days"))

   207         {

   208             print {$atfh}

   209               "rm -f \"$dir/$filename\"\n",

   210               "rmdir \"$dir\"\n";

   211             close $atfh;

   212         }

   213 

   214     }

   215 

   216     # create the view

   217     my %tt = (view => $view);

   218     my $tt = Template->new($TT_CONFIG)

   219       or die $Template::ERROR;

   220 

   221     # List the current content

   222     if (my @files = map { deslash $_ } glob "$user_dir/*-*/*") {

   223 

   224         foreach (map { /(.*)/ } sort { -M $a <=> -M $b } @files) {

   225 

   226             my %file;

   227 

   228             my ($file, $dir) = fileparse($_);

   229             $dir = substr $dir,

   230               length $VAR;    # make it relative to $VAR

   231 

   232             # FIXME: use the rx* patterns from above

   233             $dir =~ m{/(?<expires>[a-z\d]{6})-(?<hash>[a-z\d]+)-(?<delete>.)}i

   234               or next;

   235             my ($hash, $expires, $delete) = @{+}{qw/hash expires delete/};

   236             if (${expires} <= time and $delete eq 'e') {

   237                 /(.*)/;

   238                 unlink $_  or die "Can't unlik $_: $!\n";

   239                 rmdir $dir or die "Can't rmdir $dir: $!\n";

   240                 next;

   241             }

   242 

   243             my $d;

   244             if ($delete eq 'e') {

   245                 $d = localtime ${expires};

   246             }

   247             elsif ($delete eq 'd') {

   248                 $d = 'unmittelbar nach Download';

   249             }

   250             else {

   251                 $d = 'nur manuell';

   252             }

   253 

   254             $file{name}          = $file;

   255             $file{link}          = "$ENV{PATH_INFO}/$dir$file";

   256             $file{size}          = humanize -s $_;

   257             $file{uploaded}      = (stat _)[9];

   258             $file{removal}{type} = $d;

   259             $file{removal}{link} = "?delete=$dir";

   260 

   261             push @{ $tt{files} }, \%file;

   262         }

   263 

   264     }

   265     $tt->process('inventory.html', \%tt) or die $tt->error();

   266     return 0;

   267 }

   268 

   269 sub deletedir {

   270     remove_tree

   271       map  { /^(\/.*)/ }

   272       grep { /^\Q$VAR\E/ } @_;

   273 }

   274 

   275 sub humanize {

   276     my $_     = shift;

   277     my @units = qw(B K M G T);

   278     while (length int > 3 and @units) {

   279         $_ = sprintf "%.1f" => $_ / 1024;

   280         shift @units;

   281     }

   282     croak "filesize is too big (can't convert to human readable number)"

   283       if !@units;

   284     return "$_$units[0]";

   285 }

   286 

   287 sub deslash { $_[0] =~ s{/+}{/}gr }

   288 

   289 sub confirm {

   290     my ($base, $mimetype) = @_;

   291     my %tt = (

   292         file => {

   293             name     => $base,

   294             mimetype => $mimetype

   295         }

   296     );

   297     my $tt = Template->new($TT_CONFIG)

   298       or die $Template::ERROR;

   299     $tt->process('confirm.html' => \%tt);

   300     exit 0;

   301 }

   302 

   303 sub unbase62 {

   304     my @digits = reverse split '', shift;

   305     state $value = do {

   306         my %value;

   307         for (

   308             my ($symbol, $value) = (base62(0), 0) ;

   309             length($symbol) == 1 ;

   310             $symbol = base62 ++$value

   311           )

   312         {

   313             $value{$symbol} = $value;

   314         }

   315         \%value;

   316     };

   317     state $base = scalar keys %$value;

   318 

   319     my $unbase62 = 0;

   320     while (my ($p, $symbol) = each @digits) {

   321         $unbase62 += $value->{$symbol} * $base**$p;

   322     }

   323     return $unbase62;

   324 }

   325 

   326 sub base62 {

   327     my $n = shift // $_;

   328     die 'input is >MAXINT' if $n == $n - 1 or $n == $n + 1;

   329     state $digits = [0 .. 9, 'a' .. 'z', 'A' .. 'Z'];

   330     state $base = @$digits;

   331     my @result;

   332 

   333     for (; $n >= $base ; $n = int($n / $base)) {

   334         my $mod = $n % $base;

   335         unshift @result, $digits->[$mod];

   336     }

   337     unshift @result, $digits->[$n];

   338     join '', @result;

   339 }

   340 

   341 sub untaint {

   342     my ($_, $rx) = (@_, qr((\w+)));

   343     /$rx/;

   344     die sprintf("%s:%s:%d: untaint('%s', %s): not defined\n", caller, $_, $rx)

   345       if not defined $1;

   346     return $1;

   347 }

   348 

   349 sub gen_uuid {

   350 

   351     #open my $f, '/dev/urandom' or croak;

   352     #read $f, my($_), 128/8;

   353     #/^(.*)$/;

   354     #die join '-', map { base62 $_ } unpack 'Q*', $1;

   355     return base62 int rand(2**64);

   356 }