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 

    44 sub human;        # convert numbers to human readable format

    45 sub deletedir;    # safely delete directories

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

    47 sub deslash;      # cleanup a path name

    48 sub gen_uuid;

    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             $d = gen_uuid();

   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 $uuid = gen_uuid();

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

   158         my ($delete, $expires);

   159         # sanitize expires

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

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

   162 

   163         $expires = time + $days * 86400;

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

   165         if ($days == 0) {

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

   167         }

   168         elsif ($days == -1) {

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

   170         }

   171 

   172         # sanitizing the filename

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

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

   175         $filename = $1;

   176 

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

   178         make_path($dir);

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

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

   181         print {$outfh} <$file>;

   182 

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

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

   185         {

   186             print {$atfh}

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

   188               "rmdir \"$dir\"\n";

   189             close $atfh;

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

   191         }

   192 

   193     }

   194     print hr;

   195 

   196     # List the current content

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

   198 

   199         print p <<__;

   200         <@files>

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

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

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

   204 wird die Datei automatisch gelöscht.

   205 __

   206 

   207         print start_table,

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

   209 

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

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

   212             $dir = substr $dir,

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

   214 

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

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

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

   218                 /(.*)/;

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

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

   221                 next;

   222             }

   223 

   224             my $d;

   225             if ($delete eq 'l') {

   226                 $d = localtime ${expires};

   227             }

   228             elsif ($delete eq 'd') {

   229                 $d = 'unmittelbar nach Download';

   230             }

   231             else {

   232                 $d = 'nur manuell';

   233             }

   234 

   235             print Tr(

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

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

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

   239                 td($d),

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

   241             );

   242         }

   243 

   244         print end_table, hr;

   245     }

   246 

   247     print start_multipart_form, start_table,

   248       Tr(td("Dateiname: "),

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

   250       ),

   251       Tr(

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

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

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

   255       ),

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

   257       end_table,

   258       end_multipart_form,

   259       @footer,

   260       end_html;

   261 }

   262 

   263 sub deletedir {

   264     remove_tree

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

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

   267 }

   268 

   269 sub human {

   270     my $_     = shift;

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

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

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

   274         shift @units;

   275     }

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

   277       if !@units;

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

   279 }

   280 

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

   282 

   283 sub confirm {

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

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

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

   287       h1 "Download bestätigen";

   288     print hr, p <<__;

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

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

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

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

   293         per Knopfdruck.

   294 __

   295     print start_form,

   296       hidden('confirmed', 'yes'),

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

   298       end_form,

   299       @footer,

   300       end_html;

   301     exit 0;

   302 }

   303 

   304 sub base62 {

   305     my $n = shift;

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

   307     state $base = @$digits;

   308     my @result;

   309 

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

   311         my $mod = $n % $base;

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

   313     }

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

   315     join '', @result;

   316 }

   317 

   318 sub gen_uuid {

   319     open my $f, '/dev/random' or croak;

   320     read $f, my $_, 64/8;

   321     /^(.*)$/;

   322     return join '-', map { base62 $_ } unpack 'Q*', $1;

   323 }