1 #! /usr/bin/perl -T

     2 # FIXME: UPDATE {{

     3 # Example .htaccess

     4 # | Options -Indexes

     5 # | <Files upload.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/upload.pl

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

    22 # gesetzt werden.

    23 #

    24 # }}

    25 #

    26 

    27 # STATUS: Proof of Concept!

    28 # NEEDS: Security review!

    29 

    30 use 5.014;

    31 use strict;

    32 use warnings;

    33 use CGI qw(:all *table);

    34 use CGI::Carp qw(fatalsToBrowser);

    35 use CGI::Pretty;

    36 use IO::File;

    37 use File::Basename;

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

    39 use File::Spec::Functions;

    40 use File::MimeInfo qw(mimetype);

    41 use Cwd qw(getcwd realpath);

    42 use Digest::MD5 qw(md5_hex);

    43 use OSSP::uuid;

    44 

    45 sub human;        # 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 

    50 my $uuid = qr/[[:xdigit:]-]{36}/;

    51 my $hash = qr/[[:xdigit:]]{32}/;

    52 

    53 umask 077;

    54 

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

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

    57 

    58 my $ONCE_VAR = do {

    59     $ENV{ONCE_VAR} =~ /^(\/\S+)/;

    60     die "Please define (correct) env ONCE_VAR\n"

    61       if not defined $1;

    62     $1;

    63 };

    64 

    65 my @footer = (hr,

    66     div(

    67         { -align => "right" },

    68         a(

    69             {

    70                 -href =>

    71                   "https://ssl.schlittermann.de/hg/anon-upload/file/once/"

    72             } => "Scripting"

    73         ),

    74         " © 2010,2011,2015 ",

    75         a({ -href => "http://www.schlittermann.de/" } => "Heiko Schlittermann"),

    76         " © 2014 ",

    77         a({ -href => "http://www.schlittermann.de/" } => "Matthias Förste")

    78     )

    79 );

    80 

    81 MAIN: {

    82 

    83     # Download?

    84     if ($ENV{PATH_INFO} =~

    85         m{(?<path>(?<store>(?<view>/$hash|$uuid)/$uuid-\d+-.)/(?<base>.*))})

    86     {

    87         my $view  = deslash realpath catfile $ONCE_VAR, $+{view};

    88         my $store = deslash realpath catfile $ONCE_VAR, $+{store};

    89         my $file  = deslash realpath catfile $ONCE_VAR, $+{path};

    90         my $base  = $+{base};

    91 

    92         unless (-f $file) {

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

    94             exit 0;

    95         }

    96 

    97         my $mimetype = mimetype($file);

    98         confirm $base, $mimetype

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

   100 

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

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

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

   104 

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

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

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

   108             print while <$f>;

   109         }

   110         exit 0;

   111 

   112     }

   113 

   114     # UPLOAD / VIEW request

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

   116 

   117     # pre condition checks

   118     -d $ONCE_VAR

   119       or mkdir $ONCE_VAR => 0777

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

   121 

   122     -x -w $ONCE_VAR

   123       or die "Can't write to $ONCE_VAR: $!\n";

   124 

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

   126         my ($v, $d);

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

   128             $v = $1;

   129             $d = md5_hex($1);

   130         }

   131         else {

   132             tie $d => 'OSSP::uuid::tie', 'v4';

   133             $v = 'anonymous';

   134         }

   135         $v, deslash catfile($ONCE_VAR, $d);

   136     };

   137 

   138     if (param('delete') =~ m{(?<store>(?<view>$uuid|$hash)/$uuid-\d+-./?)}) {

   139 

   140         # FIXME: sanitization

   141         my $store = deslash catfile $ONCE_VAR, $+{store};

   142         my $view  = deslash catfile $ONCE_VAR, $+{view};

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

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

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

   146         exit 0;

   147     }

   148 

   149     print header(-charset => "UTF-8"),

   150       start_html(-title => "once"),

   151       h1 "Ansicht: $view";

   152 

   153     # print Dump;

   154 

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

   156         my $days = param('expires');

   157         my ($delete, $expires);

   158         tie my $uuid => 'OSSP::uuid::tie', 'v4';

   159 

   160         # sanitize expires

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

   162         $days = defined $1 ? $1 : 10;

   163 

   164         $expires = time + $days * 86400;

   165         $delete  = 'l';                    # on file[l]ist

   166         if ($days == 0) {

   167             $delete = 'd';                 # on first [d]ownload

   168         }

   169         elsif ($days == -1) {

   170             $delete = 'm';                 # only [m]anually

   171         }

   172 

   173         # sanitizing the filename

   174         (my $filename = $file) =~ tr /\\/\//;

   175         $filename =~ /(.*)/;

   176         $filename = $1;

   177 

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

   179         make_path($dir);

   180         my $outfh = new IO::File ">$dir/$filename"

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

   182         print {$outfh} <$file>;

   183 

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

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

   186         {

   187             print {$atfh}

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

   189               "rmdir \"$dir\"\n";

   190             close $atfh;

   191             system("cat /tmp/log");

   192         }

   193 

   194     }

   195     print hr;

   196 

   197     # List the current content

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

   199 

   200         print p <<__;

   201         <@files>

   202 Der gültige Download-Link ist die Link-Adresse, die sich hinter

   203 dem Datei-Namen verbirgt. (Firefox: Rechte Maustaste, Link-Location).

   204 Nach Ablauf des <a href="http://de.wikipedia.org/wiki/Mindesthaltbarkeitsdatum">MHD</a>

   205 wird die Datei automatisch gelöscht.

   206 __

   207 

   208         print start_table,

   209           Tr(th { align => "left" }, [qw/Name Größe Hochgeladen Löschung/]);

   210 

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

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

   213             $dir = substr $dir,

   214               length $ONCE_VAR;    # make it relative to $ONCE_VAR

   215 

   216             $dir =~ /(\S+)-(\d+)-(.)\/?$/ or next;

   217             my ($hash, $expires, $delete) = ($1, $2, $3);

   218             if (${expires} <= time and $delete eq 'l') {

   219                 /(.*)/;

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

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

   222                 next;

   223             }

   224 

   225             my $d;

   226             if ($delete eq 'l') {

   227                 $d = localtime ${expires};

   228             }

   229             elsif ($delete eq 'd') {

   230                 $d = 'unmittelbar nach Download';

   231             }

   232             else {

   233                 $d = 'nur manuell';

   234             }

   235 

   236             print Tr(

   237                 td(a { href => "$ENV{PATH_INFO}/$dir$file" }, $file),

   238                 td({ align => "right" }, human((stat $_)[7])),

   239                 td(scalar localtime +(stat $_)[9]),

   240                 td($d),

   241                 td(a({ href => "?delete=$dir" }, 'remove'))

   242             );

   243         }

   244 

   245         print end_table, hr;

   246     }

   247 

   248     print start_multipart_form, start_table,

   249       Tr(td("Dateiname: "),

   250         td(filefield(-name => "upload", -default => "nothing")),

   251       ),

   252       Tr(

   253         td("Löschen in: "),

   254         td(textfield(-name => "expires", -default => 0)),

   255         td("Tagen (0: unmittelbar nach Download; -1: nur manuell)")

   256       ),

   257       Tr(td(), td(submit(-value => "Hochladen")),),

   258       end_table,

   259       end_multipart_form,

   260       @footer,

   261       end_html;

   262 }

   263 

   264 sub deletedir {

   265     remove_tree

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

   267       grep { /^\Q$ONCE_VAR\E/ } @_;

   268 }

   269 

   270 sub human {

   271     my $_     = shift;

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

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

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

   275         shift @units;

   276     }

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

   278       if !@units;

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

   280 }

   281 

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

   283 

   284 sub confirm {

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

   286     print header(-charset => "UTF-8"),

   287       start_html(-title => "once"),

   288       h1 "Download bestätigen";

   289     print hr, p <<__;

   290         Die Datei `$base' ($mimetype), die Sie herunterladen möchten, wird nach Abschluß des

   291         Downloads gelöscht. Virenscanner oder andere Programme, die den Link

   292         möglicherweise automatisiert aufrufen, könnten eine versehentliche

   293         Löschung der Datei auslösen. Bestätigen Sie deshalb bitte den Download

   294         per Knopfdruck.

   295 __

   296     print start_form,

   297       hidden('confirmed', 'yes'),

   298       submit(-value => 'Bestätigung'),

   299       end_form,

   300       @footer,

   301       end_html;

   302     exit 0;

   303 }