lib/dop

   1 #!/usr/bin/perl -wT
   2
   3 # F*EX document output
   4 #
   5 # is a subprogram of fexsrv! do not run it directly!
   6 #
   7 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
   8 #
   9
  10 use File::Basename;
  11 use CGI::Carp   qw(fatalsToBrowser);
  12 use Fcntl       qw(:flock :seek :mode);
  13 use POSIX       qw(strftime locale_h);
  14 use Cwd         qw(getcwd abs_path);
  15
  16 # import from fex.pp
  17 our ($bs,$tmpdir,@doc_dirs);
  18
  19 my $log = "$logdir/dop.log";
  20
  21 # POSIX time format needed for HTTP header
  22 setlocale(LC_TIME,'POSIX');
  23
  24 sub dop {
  25   my $doc = shift;
  26   my $source = shift;
  27   my $seek = 0;
  28   my $stop = 0;
  29   my ($link,$host,$path,$range);
  30
  31   our $error = 'F*EX document output ERROR';
  32
  33   security_check($doc);
  34
  35   # reget?
  36   if ($range = $ENV{HTTP_RANGE}) {
  37     $seek = $1 if $range =~ /^bytes=(\d+)-/i;
  38     $stop = $1 if $range =~ /^bytes=\d*-(\d+)/i;
  39   }
  40
  41   # redirect on relative symlinks without "../"
  42   if ($link = readlink($doc) and
  43       $link !~ m:^/: and $link !~ m:\.\./: and $link !~ /^:.+:$/) {
  44     $path = $ENV{REQUEST_URI};
  45     $path =~ s:[^/]*$::;
  46     $doc = "$path/$link";
  47     $doc =~ s:/+:/:g;
  48     $doc =~ s:^/::;
  49     $host = $ENV{HTTP_HOST} || $hostname;
  50     nvt_print(
  51       "HTTP/1.1 301 Moved Permanently",
  52       "Location: $ENV{PROTO}://$host/$doc",
  53       "Content-Length: 0",
  54       "Connection: close",
  55       ""
  56     );
  57     &reexec;
  58   }
  59
  60   # watchdog documents
  61   if (@wdd and $wdd and grep { $doc =~ /$_/ } @wdd) { &$wdd($doc) }
  62
  63   my $dir = untaint(getcwd());
  64   chdir(dirname($doc));
  65   http_output($doc,$seek,$stop);
  66   chdir($dir);
  67 }
  68
  69 sub http_output {
  70   my ($file,$seek,$stop) = @_;
  71   my ($filename,$files,$streamfile,$size,$total_size);
  72   my ($data,$type);
  73   my ($var,$env,$con);
  74   my @files;
  75   my $htmldoc = '';
  76   my $htauth;
  77   my @s;
  78   my $s = 0;
  79   my $b = 0;
  80   my $http_client = $ENV{HTTP_USER_AGENT} || '';
  81   local $_;
  82
  83   # extra security check: document must not be in lib or spool directory
  84   if (path_match($file,$FEXLIB) or path_match($file,$spooldir)) {
  85     http_error(403);
  86   }
  87
  88   security_check($file);
  89   $htauth = dirname($file).'/.htauth';
  90   require_auth($htauth,$file) if -f $htauth;
  91
  92   if (-f $file) {
  93     # normal file
  94     open $file,'<',$file or http_error(400);
  95     security_check($file);
  96   } elsif ($file =~ /(.+)\.gz$/ and -f $1) {
  97     @files = ($1);
  98     open $file,'-|',qw'gzip -c',@files or http_error(503);
  99   } elsif ($file =~ /(.+)\.tgz$/ and -f "$1.tar") {
 100     @files = ("$1.tar");
 101     open $file,'-|',qw'gzip -c',@files or http_error(503);
 102   } elsif ($file =~ /(.+)\.(tar|tgz|zip)$/ and
 103            @s = lstat($streamfile = "$1.stream") and $s[4] == $<)
 104   {
 105     # streaming file (only if it is owned by user fex)
 106     chdir dirname($file);
 107     security_check($file);
 108     if (-l $streamfile and readlink($streamfile) =~ /^:(.+):$/) {
 109       # special symlink pointer file for streaming
 110       @files = split(/:/,$1);
 111     } elsif (open $streamfile,$streamfile) {
 112       # special streaming file
 113       while (<$streamfile>) {
 114         chomp;
 115         if (/^(\/.*):/) {
 116           chdir $1;
 117           security_check($1);
 118         } else {
 119           push @files,$_;
 120         }
 121       }
 122     } else {
 123       http_error(503);
 124     }
 125     close $streamfile;
 126     foreach (@files) {
 127       if (/^\// or /\.\.\//) {
 128         # absolute path or relative path with parent directory is not allowed
 129         http_error(403);
 130       }
 131       if (@s = stat($_) and not($s[2] & S_IRGRP) or not -r $_) {
 132         # file must be readable by user and group
 133         http_error(403);
 134       }
 135     }
 136     http_error(416) if $ENV{HTTP_RANGE};
 137     close STDERR;
 138     if    ($file =~ /\.tar$/) { @a = qw'tar --exclude *~ --exclude .* -cf -' }
 139     elsif ($file =~ /\.tgz$/) { @a = qw'tar --exclude *~ --exclude .* -czf -' }
 140     elsif ($file =~ /\.zip$/) { @a = qw'zip -x *~ */.*/* @ -rq -' }
 141     else { http_error(400) }
 142     open $file,'-|',@a,@files or http_error(503);
 143   } else {
 144     http_error(404);
 145   }
 146
 147   $type = 'application/octet-stream';
 148   if    ($file =~ /\.html$/)    { $type = 'text/html' }
 149   # elsif ($file =~ /\.txt$/)   { $type = 'text/plain' }
 150   elsif ($file =~ /\.css$/)     { $type = 'text/css' }
 151   elsif ($file =~ /\.js$/)      { $type = 'text/javascript' }
 152   elsif ($file =~ /\.ps$/)      { $type = 'application/postscript' }
 153   elsif ($file =~ /\.pdf$/)     { $type = 'application/pdf' }
 154   elsif ($file =~ /\.jpg$/)     { $type = 'image/jpeg' }
 155   elsif ($file =~ /\.png$/)     { $type = 'image/png' }
 156   elsif ($file =~ /\.gif$/)     { $type = 'image/gif' }
 157   elsif ($file !~ /\.(tar|tgz|zip|jar|rar|arj|7z|bz2?|gz)$/) {
 158     my $qfile = untaint(abs_path($file));
 159     $qfile =~ s/([^\/\.\+\w!=,_-])/\\$1/g;
 160     $_ = `file $qfile`;
 161     if (/HTML/) {
 162       $type = 'text/html';
 163     } elsif (/text/i and not -x $file) {
 164       $type = 'text/plain';
 165       if    (/\sASCII\s/)    { $type .= "; charset=us-ascii" }
 166       elsif (/(ISO-[\w-]+)/) { $type .= "; charset=".lc($1) }
 167       else                   { $type .= "; charset=utf-8" }
 168     }
 169   }
 170
 171   # show sourcecode if URL ends with '!'
 172   # to avoid this for a HTML file, simple do a: chmod o-r file
 173   if ($type eq 'text/html') {
 174     if ($htmlsource) {
 175       if (@s = stat($file) and $s[2] & S_IROTH) {
 176         $type = 'text/plain';
 177       } else {
 178         http_error(403);
 179       }
 180     }
 181   } elsif ($ENV{'QUERY_STRING'} eq '!') {
 182     $type = 'text/plain';
 183   }
 184
 185
 186   if ($type eq 'text/html') {
 187     $seek = $stop = 0;
 188     local $^W = 0;
 189     local $/;
 190     $htmldoc = <$file>;
 191     while ($htmldoc =~ s/\n##.*?\n/\n/) {};
 192     # evaluate #if ... #else ... #elseif ... #endif blocks
 193     my $mark = randstring(16);
 194     while ($htmldoc =~ s/\n(#if\s+(.+?)\n.+?\n)#endif/\n$mark/s) {
 195       $_ = $1;
 196       # if block
 197       if (eval $2) {
 198         s/#if.*\n//;
 199         s/\n#else.*//s;
 200         $htmldoc =~ s/$mark/$_/;
 201       } else {
 202         # elseif blocks
 203         while (s/.*?\n#elseif\s+(.+?)\n//s) {
 204           if (eval $1) {
 205             s/\n#else.*//s;
 206             $htmldoc =~ s/$mark/$_/;
 207           }
 208         }
 209         # else block left?
 210         if ($htmldoc =~ /$mark/) {
 211           s/.*\n#else\s*\n//s or $_ = '';
 212           $htmldoc =~ s/$mark/$_/;
 213         }
 214       }
 215     };
 216     # evaluate #include
 217     while ($htmldoc =~ s/\n#include "(.*?)"/\n$mark/s) {
 218       my $file = $1;
 219       my $include = '';
 220       if (open $file,$file) {
 221         $include = <$file>;
 222         close $file;
 223       }
 224       $dynamic = $htmldoc =~ s/$mark/$include/;
 225     }
 226     # evaluate <<perl-code>>
 227     while ($htmldoc =~ /<<(.+?)>>/s) {
 228       local $pc = $1;
 229       local $__ = '';
 230       tie *STDOUT => "Buffer",\$__;
 231       $__ .= eval $pc;
 232       untie *STDOUT;
 233       $dynamic = $htmldoc =~ s/<<(.+?)>>/$__/s;
 234     };
 235     # substitute $variable$ with value from environment (if present)
 236     while ($htmldoc =~ /\$([\w_]+)\$/g) {
 237       $var = $1;
 238       if (defined($env = $ENV{$var})) {
 239         $htmldoc =~ s/\$$var\$/$env/g;
 240       }
 241     };
 242     $total_size = $size = $s = length($htmldoc);
 243   } else {
 244     if (@files) {
 245       $size = 0;
 246     } else {
 247       $total_size = -s $file || 0;
 248       $size = $total_size - $seek - ($stop ? $total_size-$stop-1 : 0);
 249     }
 250   }
 251
 252   if ($size < 0) {
 253     http_header('416 Requested Range Not Satisfiable');
 254     exit;
 255   }
 256
 257   alarm($timeout*10);
 258
 259   if ($seek or $stop) {
 260     my $range;
 261     if ($stop) {
 262       $range = sprintf("bytes %s-%s/%s",$seek,$stop,$total_size);
 263     } else {
 264       $range = sprintf("bytes %s-%s/%s",$seek,$total_size-1,$total_size);
 265     }
 266     nvt_print(
 267       'HTTP/1.1 206 Partial Content',
 268       'Server: fexsrv',
 269       "Content-Length: $size",
 270       "Content-Range: $range",
 271       "Content-Type: $type",
 272       '',
 273     );
 274   } else {
 275     # streaming?
 276     if (@files) {
 277       nvt_print(
 278         'HTTP/1.1 200 OK',
 279         'Server: fexsrv',
 280         "Expires: 0",
 281         "Content-Type: $type",
 282         '',
 283       );
 284     } else {
 285       # Java (clients) needs Last-Modified header!
 286       # if there are locale versions, use actual time for Last-Modified
 287       # to enforce reload of page
 288       $file =~ m{/htdocs/(.+)};
 289       my @lfiles = glob("$FEXHOME/locale/*/htdocs/$1");
 290       my $date = ($dynamic or @lfiles > 1) ?
 291                  strftime("%a, %d %b %Y %T GMT",gmtime(time)) :
 292                  http_date($file);
 293       nvt_print(
 294         'HTTP/1.1 200 OK',
 295         'Server: fexsrv',
 296         "Last-Modified: $date",
 297         "Expires: 0",
 298         "Content-Length: $size",
 299         "Content-Type: $type",
 300       );
 301       nvt_print("Set-Cookie: locale=$locale") if $use_cookies and $locale;
 302       nvt_print('');
 303     }
 304   }
 305
 306   if ($ENV{REQUEST_METHOD} eq 'GET') {
 307     if ($type eq 'text/html') {
 308       alarm($timeout*10);
 309       print $htmldoc;
 310     } else {
 311       # binary data # can be stream!
 312       seek $file,$seek,0 if $seek;
 313       while ($b = read($file,$data,$bs)) {
 314         if ($stop and $s+$b > $size) {
 315           $b = $size-$s;
 316           $data = substr($data,0,$b)
 317         }
 318         $s += $b;
 319         alarm($timeout*10);
 320         print $data or last;
 321       }
 322     }
 323     fdlog($log,$file,$s,$size) if $s;
 324   }
 325
 326   alarm(0);
 327   close $file;
 328   exit if @files; # streaming end
 329   return $s;
 330 }
 331
 332
 333 # show directory index
 334 sub showindex {
 335   my $dir = shift;
 336   my ($htmldoc,$size);
 337   my @links = ();
 338   my @dirs = ();
 339   my @files = ();
 340   my $uri = $ENV{REQUEST_URI};
 341   my $allowed;
 342   my ($htindex,$htauth);
 343   local $_;
 344
 345   $uri =~ s:/+$::;
 346   $dir =~ s:/+$::;
 347
 348   security_check($dir);
 349
 350   $htindex = "$dir/.htindex";
 351   $htauth  = "$dir/.htauth";
 352
 353   open $htindex,$htindex or http_error(403);
 354   require_auth($htauth,$dir) if -f $htauth;
 355
 356   # .htindex may contain listing regexp
 357   chomp ($allowed = <$htindex>||'.');
 358   close $htindex;
 359
 360   opendir $dir,$dir or http_error(503);
 361   while (defined($_ = readdir $dir)) {
 362     next if /^[.#]/ or /~$/;
 363     if (@s = lstat "$dir/$_" and ($s[2] & (S_IRGRP|S_IROTH))) {
 364       if    (-l _) { push @links,$_ }
 365       elsif (-d _) { push @dirs,$_ }
 366       elsif (-f _) { push @files,$_ }
 367     }
 368   }
 369   closedir $dir;
 370
 371   # parent directory listable?
 372   if ($uri =~ m:(/.+)/.+: and -f "$dir/../.htindex") {
 373     unshift @dirs,$1;
 374   }
 375
 376   # first the (sub)directories
 377   $htmldoc = "<HTML>\n<h1>$uri/</h1>\n";
 378   foreach my $d (sort @dirs) {
 379     if ($d =~ m:^/: and -f "$d/.htindex") {
 380       $htmldoc .= "<h3><a href=\"$d/\">$d/</a></h3>\n";
 381     } elsif (-f "$dir/$d/.htindex") {
 382       $htmldoc .= "<h3><a href=\"$uri/$d/\">$uri/$d/</a></h3>\n";
 383     }
 384   }
 385
 386 #  # then the symlinks
 387 #  $htmldoc .= "\n<pre>\n";
 388 #  my $link;
 389 #  foreach my $l (sort @links) {
 390 #    if ($l =~ /$allowed/ and $link = readlink "$dir/$l" and $link =~ /^[^.\/]/) {
 391 #      $htmldoc .= "$l -> <a href=\"$link\">$dir/$link</a>\n";
 392 #    }
 393 #  }
 394
 395   # then the files
 396   $htmldoc .= "\n<pre>\n";
 397   foreach my $f (sort @files) {
 398     if ($f =~ /$allowed/) {
 399       $htmldoc .= sprintf "%20s %20s <a href=\"%s/%s\">%s</a>\n",
 400                           isodate(mtime("$dir/$f")),
 401                           d3(-s "$dir/$f"||0),
 402                           $uri,urlencode($f),$f;
 403     }
 404   }
 405   $htmldoc .= "</pre>\n</HTML>\n";
 406
 407   $size = length($htmldoc);
 408   nvt_print(
 409     'HTTP/1.1 200 OK',
 410     'Server: fexsrv',
 411     "Content-Length: $size",
 412     "Content-Type: text/html",
 413     '',
 414   );
 415   print $htmldoc;
 416   fdlog($log,"$dir/",$size,$size);
 417 }
 418
 419
 420 sub mtime {
 421   return (lstat shift)[9];
 422 }
 423
 424
 425 sub d3 {
 426   local $_ = shift;
 427   while (s/(\d)(\d\d\d\b)/$1,$2/) {};
 428   return $_;
 429 }
 430
 431
 432 sub http_date {
 433   my $file = shift;
 434   my @stat;
 435
 436   if (@stat = stat($file)) {
 437     return strftime("%a, %d %b %Y %T GMT",gmtime($stat[9]));
 438   } else {
 439     return 0;
 440   }
 441 }
 442
 443
 444 sub path_match {
 445   my $p1 = abs_path(shift);
 446   my $p2 = abs_path(shift);
 447
 448   if (defined $p1 and defined $p2) {
 449     return 1 if $p1          =~ /^\Q$p2/;
 450     return 2 if dirname($p1) =~ /^\Q$p2/;
 451   }
 452   return 0;
 453 }
 454
 455
 456 # return real file name (from symlink)
 457 sub realfilename {
 458   my $file = shift;
 459
 460   return '' unless -e $file;
 461
 462   if (-l $file) {
 463     return realfilename(readlink($file));
 464   } else {
 465     return $file;
 466   }
 467 }
 468
 469
 470 sub security_check {
 471   my $file = shift; # can be directory, too!
 472   my @s;
 473
 474   # client ip allowed?
 475   access_check($file);
 476
 477   # documents with leading . are not allowed
 478   if (abs_path($file) =~ /\/\./) {
 479     errorlog("$file with leading .");
 480     http_error(403);
 481   }
 482
 483   if (-f $file) {
 484
 485     # document filename must not contain @
 486     if (realfilename($file) =~ /@/ or abs_path($file) =~ /@/) {
 487       errorlog("$file contains @");
 488       http_error(403);
 489     }
 490
 491     # document filename must not end with ~
 492     if (realfilename($file) =~ /~$/) {
 493       errorlog("$file ends with ~");
 494       http_error(403);
 495     }
 496
 497     # file must be group or world readable
 498     if (@s = stat($file) and not($s[2] & (S_IRGRP|S_IROTH))) {
 499       errorlog("$file not group or world readable");
 500       http_error(403);
 501     }
 502
 503     # symlink to regular file and symlink owned by root or fex? ==> ok!
 504     if (-l $file and path_match(dirname($file),$docdir)) {
 505       @s = lstat($file);
 506       return if $s[4] == 0 or $s[4] == $<;
 507     }
 508
 509   }
 510
 511   # file in allowed directory? ==> ok!
 512   foreach my $dir (@doc_dirs) {
 513     return if path_match($file,$dir);
 514   }
 515
 516   errorlog("$file not in \@doc_dirs");
 517   http_error(403);
 518 }
 519
 520 # security check: client ip allowed?
 521 sub access_check {
 522   my $file = abs_path(shift);
 523   my $dir = $file;
 524   my $af;
 525   local $_;
 526
 527   $dir .= '/x' if -d $dir;
 528
 529   while ($dir = dirname($dir) and $dir ne '/') {
 530     $af = "$dir/.htaccessfrom";
 531     if (open $af,$af) {
 532       while (<$af>) {
 533         s/\s//g;
 534         if (ipin($ra,$_)) {
 535           close $af;
 536           return;
 537         }
 538       }
 539       errorlog("no access to $file by $af");
 540       http_error(403);
 541     }
 542   }
 543
 544 }
 545
 546 # HTTP Basic authentication
 547 sub require_auth {
 548   my $htauth = shift;
 549   my $doc = shift;
 550   my ($realm,$auth);
 551   my @http_auth;
 552   my $uri = $ENV{REQUEST_URI} || '/';
 553
 554   $uri =~ s/\/index\.html$//;
 555   $uri =~ s/\/$//;
 556
 557   if (-d $doc or $doc =~ /\/index\.html$/) {
 558     $realm = $uri;
 559   } else {
 560     $realm = dirname($uri);
 561   }
 562
 563   $auth = slurp($htauth);
 564   unless ($auth and $realm) {
 565     http_header("200 OK");
 566     print html_header("$ENV{SERVER_NAME} no authentication");
 567     pq(qq(
 568       '<h3><code>$htauth</code> missing</h3>'
 569       '</body></html>'
 570     ));
 571     exit;
 572   }
 573   chomp $auth;
 574
 575   if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/)
 576   { @http_auth = split(':',decode_b64($1)) }
 577   if (@http_auth != 2 or $http_auth[1] ne $auth) {
 578     http_header(
 579       '401 Authorization Required',
 580       "WWW-Authenticate: Basic realm=\"$realm\"",
 581       'Content-Length: 0',
 582     );
 583     # control back to fexsrv for further HTTP handling
 584     &reexec;
 585   }
 586 }
 587
 588
 589 # function for <<perl-code>> inside HTML documents
 590 sub out {
 591   $__ .= join('',@_);
 592   return '';
 593 }
 594
 595 # tie STDOUT to buffer variable (redefining print)
 596 package Buffer;
 597
 598 sub TIEHANDLE {
 599   my ($class,$buffer) = @_;
 600   bless $buffer,$class;
 601 }
 602
 603 sub PRINT {
 604   my $buffer = shift;
 605   $$buffer .= $_ foreach @_;
 606 }
 607
 608 sub PRINTF {
 609   my $buffer = shift;
 610   my $fmt = shift @_;
 611   $$buffer .= sprintf($fmt,@_);
 612 }
 613
 614 1;