upload.pl
branchonce
changeset 36 a9b52c555cd1
parent 35 1800d3b7d5a6
child 38 41f2c1fbc288
child 40 8742c4b2d5f1
equal deleted inserted replaced
35:1800d3b7d5a6 36:a9b52c555cd1
    36 my $DIR     = "d";
    36 my $DIR     = "d";
    37 my $DIR_URI = "/once/$DIR";
    37 my $DIR_URI = "/once/$DIR";
    38 
    38 
    39 sub human($);
    39 sub human($);
    40 sub deletedir(@);
    40 sub deletedir(@);
       
    41 sub confirm;
    41 
    42 
    42 delete @ENV{ grep /PATH/, keys %ENV };
    43 delete @ENV{ grep /PATH/, keys %ENV };
    43 $ENV{PATH} = "/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin";
    44 $ENV{PATH} = "/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin";
    44 
    45 
    45 $_ = dirname $DIR;
    46 $_ = dirname $DIR;
    46 -d or mkdir $_ => 0750
    47 -d or mkdir $_ => 0750
    47   or die "Can't mkdir $_: $!\n";
    48   or die "Can't mkdir $_: $!\n";
       
    49 
       
    50 my @footer = (hr,
       
    51       div(
       
    52         { -align => "right" },
       
    53         a(
       
    54             { -href => "https://ssl.schlittermann.de/hg/anon-upload/file/once/" } =>
       
    55                           "Scripting"
       
    56         ),
       
    57         " © 2010,2011 ",
       
    58         a({ -href => "http://www.schlittermann.de/" } => "Heiko Schlittermann"),
       
    59         " © 2014 ",
       
    60         a({ -href => "http://www.schlittermann.de/" } => "Matthias Förste")
       
    61       ));
    48 
    62 
    49 MAIN: {
    63 MAIN: {
    50 
    64 
    51     # assuming download request
    65     # assuming download request
    52     if (request_uri =~ m|^\Q$DIR_URI\E/(.+)$|) {
    66     if (request_uri =~ m|^\Q$DIR_URI\E/(.+)$|) {
    56         my $base     = getcwd;
    70         my $base     = getcwd;
    57         my $absolute;
    71         my $absolute;
    58         unless ($absolute = realpath "$base/$DIR/$relative") {
    72         unless ($absolute = realpath "$base/$DIR/$relative") {
    59             die "Can't realpath '$base/$DIR/$relative': $!"
    73             die "Can't realpath '$base/$DIR/$relative': $!"
    60               unless exists $!{ENOENT} and $!{ENOENT};
    74               unless exists $!{ENOENT} and $!{ENOENT};
    61             print header('text/plain', '404 Not found');
    75             print header('text/plain', '404 Not found'), 'Not found';
    62             print "Not found";
       
    63             exit 0;
    76             exit 0;
    64         }
    77         }
    65         $absolute =~ m|^\Q$base/$DIR\E| or die "invalid path: [$absolute]";
    78         $absolute =~ m|^\Q$base/$DIR\E| or die "invalid path: [$absolute]";
       
    79 
       
    80         (my $dir = $relative) =~ s|/[^/]+$||;
       
    81         my $delete = $dir =~ /-d$/;
       
    82 
       
    83         confirm if ($delete and not defined param('confirmed'));
    66 
    84 
    67         open F, '<', $absolute or die "Can't open '<', '$absolute': $!";
    85         open F, '<', $absolute or die "Can't open '<', '$absolute': $!";
    68         print header(-type => mimetype($absolute), -charset => 'UTF-8');
    86         print header(-type => mimetype($absolute), -charset => 'UTF-8');
    69         if (request_method() ~~ [qw(GET POST)]) {
    87         if (request_method() ~~ [qw(GET POST)]) {
    70             my ($buf, $res);
    88             my ($buf, $res);
    71             print $buf while $res = read F, $buf, 32 * 2**10;
    89             print $buf while $res = read F, $buf, 32 * 2**10;
    72             defined $res or die "Can't read: $!";
    90             defined $res or die "Can't read: $!";
    73 
    91 
    74             (my $dir = $relative) =~ s|/[^/]+$||;
    92             deletedir $dir if $delete;
    75             deletedir $dir if $dir =~ /-d$/;
       
    76         }
    93         }
    77         exit 0;
    94         exit 0;
    78 
    95 
    79     }
    96     }
    80 
    97 
   201         td(textfield(-name => "expires", -default => 0)),
   218         td(textfield(-name => "expires", -default => 0)),
   202         td("Tagen (0: unmittelbar nach Download; -1: nur manuell)")
   219         td("Tagen (0: unmittelbar nach Download; -1: nur manuell)")
   203       ),
   220       ),
   204       Tr(td(), td(submit(-value => "Hochladen")),),
   221       Tr(td(), td(submit(-value => "Hochladen")),),
   205       end_table,
   222       end_table,
   206       end_multipart_form;
   223       end_multipart_form, 
   207 
   224       @footer,
   208     print hr,
       
   209       div(
       
   210         { -align => "right" },
       
   211         a(
       
   212             { -href => "https://ssl.schlittermann.de/hg/anon-upload/file/once/" } =>
       
   213                           "Scripting"
       
   214         ),
       
   215         " &copy; 2010,2011 ",
       
   216         a({ -href => "http://www.schlittermann.de/" } => "Heiko Schlittermann"),
       
   217         " &copy; 2014 ",
       
   218         a({ -href => "http://www.schlittermann.de/" } => "Matthias Förste")
       
   219       ),
       
   220       end_html;
   225       end_html;
   221 }
   226 }
   222 
   227 
   223 sub deletedir(@) {
   228 sub deletedir(@) {
   224     for my $dir (@_) {
   229     for my $dir (@_) {
   239     }
   244     }
   240     croak "filesize is too big (can't convert to human readable number"
   245     croak "filesize is too big (can't convert to human readable number"
   241       if !@units;
   246       if !@units;
   242     return "$_$units[0]";
   247     return "$_$units[0]";
   243 }
   248 }
       
   249 
       
   250 sub confirm {
       
   251     print header(-charset => "UTF-8"),
       
   252       start_html(-title => "once"),
       
   253       h1 "Download bestätigen";
       
   254       print hr,
       
   255       p <<__;
       
   256         Die Datei die Sie herunterladen möchten wird nach Abschluß des
       
   257         Downloads gelöscht. Um zu verhindern, daß Virenscanner oder andere
       
   258         Programme die diesen Link automatisiert aufrufen die Löschung der Datei
       
   259         auslösen bestätigen Sie bitte den Download per Knopfdruck.
       
   260 __
       
   261     print start_form, hidden('confirmed', 'yes'), submit(-value => 'Bestätigung'), end_form, @footer, end_html;
       
   262     exit 0;
       
   263 }