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 use utf8;
  16
  17 # import from fex.pp
  18 our ($bs,$tmpdir,@doc_dirs);
  19
  20 my $log = 'dop.log';
  21
  22 # POSIX time format needed for HTTP header
  23 setlocale(LC_TIME,'POSIX');
  24
  25 sub dop {
  26   my $doc = shift;
  27   my $source = shift;
  28   my $seek = 0;
  29   my $stop = 0;
  30   my ($link,$host,$path,$range);
  31
  32   our $error = 'F*EX document output ERROR';
  33
  34   security_check($doc);
  35
  36   # reget?
  37   if ($range = $ENV{HTTP_RANGE}) {
  38     $seek = $1 if $range =~ /^bytes=(\d+)-/i;
  39     $stop = $1 if $range =~ /^bytes=\d*-(\d+)/i;
  40   }
  41
  42   # redirect on relative symlinks without "../"
  43   if ($link = readlink($doc) and
  44       $link !~ m:^/: and $link !~ m:\.\./: and $link !~ /^:.+:$/) {
  45     $path = $ENV{REQUEST_URI};
  46     $path =~ s:[^/]*$::;
  47     $doc = "$path/$link";
  48     $doc =~ s:/+:/:g;
  49     $doc =~ s:^/::;
  50     nvt_print(
  51       "HTTP/1.1 302 Found",
  52       "Location: /$doc",
  53       "Content-Length: 0",
  54       ""
  55     );
  56     &reexec;
  57   }
  58
  59   # watchdog documents
  60   if (@wdd and $wdd and grep { $doc =~ /$_/ } @wdd) { &$wdd($doc) }
  61
  62   my $dir = untaint(getcwd());
  63   chdir(dirname($doc));
  64   http_output($doc,$seek,$stop);
  65   chdir($dir);
  66 }
  67
  68 sub http_output {
  69   my ($file,$seek,$stop) = @_;
  70   my ($filename,$files,$streamfile,$size,$total_size);
  71   my ($data,$type);
  72   my ($var,$env,$con);
  73   my @files;
  74   my $htmldoc = '';
  75   my $htauth;
  76   my @s;
  77   my $s = 0;
  78   my $b = 0;
  79   my $http_client = $ENV{HTTP_USER_AGENT} || '';
  80   local $_;
  81
  82   # extra security check: document must not be in lib or spool directory
  83   if (path_match($file,$FEXLIB) or path_match($file,$spooldir)) {
  84     http_error(403);
  85   }
  86
  87   security_check($file);
  88   $htauth = dirname($file).'/.htauth';
  89   require_auth($htauth,$file) if -f $htauth;
  90
  91   if (-f $file) {
  92     # normal file
  93     open $file,'<',$file or http_error(400);
  94     security_check($file);
  95   } elsif ($file =~ /(.+)\.gz$/ and -f $1) {
  96     @files = ($1);
  97     open $file,'-|',qw'gzip -c',@files or http_error(503);
  98   } elsif ($file =~ /(.+)\.tgz$/ and -f "$1.tar") {
  99     @files = ("$1.tar");
 100     open $file,'-|',qw'gzip -c',@files or http_error(503);
 101   } elsif ($file =~ /(.+)\.(tar|tgz|zip)$/ and
 102            @s = lstat($streamfile = "$1.stream") and
 103            ($s[4] == $< or $s[4] == 0))
 104   {
 105     # streaming file
 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       $s = $size;
 311     } else {
 312       # binary data # can be stream!
 313       seek $file,$seek,0 if $seek;
 314       while ($b = read($file,$data,$bs)) {
 315         if ($stop and $s+$b > $size) {
 316           $b = $size-$s;
 317           $data = substr($data,0,$b)
 318         }
 319         $s += $b;
 320         alarm($timeout*10);
 321         print $data or last;
 322       }
 323     }
 324     fdlog($log,$file,$s,$size) if $s;
 325   }
 326
 327   alarm(0);
 328   close $file;
 329   exit if @files; # streaming end
 330   return $s;
 331 }
 332
 333
 334 # show directory index
 335 sub showindex {
 336   my $dir = shift;
 337   my ($htmldoc,$size);
 338   my @links = ();
 339   my @dirs = ();
 340   my @files = ();
 341   my $uri = $ENV{REQUEST_URI};
 342   my $allowed;
 343   my ($htindex,$htauth);
 344   local $_;
 345
 346   $uri =~ s:/+$::;
 347   $dir =~ s:/+$::;
 348
 349   security_check($dir);
 350
 351   $htindex = "$dir/.htindex";
 352   $htauth  = "$dir/.htauth";
 353
 354   open $htindex,$htindex or http_error(403);
 355   require_auth($htauth,$dir) if -f $htauth;
 356
 357   # .htindex may contain listing regexp
 358   chomp ($allowed = <$htindex>||'.');
 359   close $htindex;
 360
 361   opendir $dir,$dir or http_error(503);
 362   while (defined($_ = readdir $dir)) {
 363     next if /^[.#]/ or /~$/;
 364     if (@s = lstat "$dir/$_" and ($s[2] & (S_IRGRP|S_IROTH))) {
 365       if    (-l _) { push @links,$_ }
 366       elsif (-d _) { push @dirs,$_ }
 367       elsif (-f _) { push @files,$_ }
 368     }
 369   }
 370   closedir $dir;
 371
 372   # parent directory listable?
 373   if ($uri =~ m:(/.+)/.+: and -f "$dir/../.htindex") {
 374     unshift @dirs,$1;
 375   }
 376
 377   # first the (sub)directories
 378   $htmldoc = "<HTML>\n<h1>$uri/</h1>\n";
 379   foreach my $d (sort @dirs) {
 380     if ($d =~ m:^/: and -f "$d/.htindex") {
 381       $htmldoc .= "<h3><a href=\"$d/\">$d/</a></h3>\n";
 382     } elsif (-f "$dir/$d/.htindex") {
 383       $htmldoc .= "<h3><a href=\"$uri/$d/\">$uri/$d/</a></h3>\n";
 384     }
 385   }
 386
 387 #  # then the symlinks
 388 #  $htmldoc .= "\n<pre>\n";
 389 #  my $link;
 390 #  foreach my $l (sort @links) {
 391 #    if ($l =~ /$allowed/ and $link = readlink "$dir/$l" and $link =~ /^[^.\/]/) {
 392 #      $htmldoc .= "$l -> <a href=\"$link\">$dir/$link</a>\n";
 393 #    }
 394 #  }
 395
 396   # then the files
 397   $htmldoc .= "\n<pre>\n";
 398   foreach my $f (sort @files) {
 399     if ($f =~ /$allowed/) {
 400       $htmldoc .= sprintf "%20s %20s <a href=\"%s/%s\">%s</a>\n",
 401                           isodate(mtime("$dir/$f")),
 402                           d3(-s "$dir/$f"||0),
 403                           $uri,urlencode($f),$f;
 404     }
 405   }
 406   $htmldoc .= "</pre>\n</HTML>\n";
 407
 408   $size = length($htmldoc);
 409   nvt_print(
 410     'HTTP/1.1 200 OK',
 411     'Server: fexsrv',
 412     "Content-Length: $size",
 413     "Content-Type: text/html",
 414     '',
 415   );
 416   print $htmldoc;
 417   fdlog($log,"$dir/",$size,$size);
 418 }
 419
 420
 421 sub d3 {
 422   local $_ = shift;
 423   while (s/(\d)(\d\d\d\b)/$1,$2/) {};
 424   return $_;
 425 }
 426
 427
 428 sub http_date {
 429   my $file = shift;
 430   my @stat;
 431
 432   if (@stat = stat($file)) {
 433     return strftime("%a, %d %b %Y %T GMT",gmtime($stat[9]));
 434   } else {
 435     return 0;
 436   }
 437 }
 438
 439
 440 sub path_match {
 441   my $p1 = abs_path(shift);
 442   my $p2 = abs_path(shift);
 443
 444   if (defined $p1 and defined $p2) {
 445     return 1 if $p1          =~ /^\Q$p2/;
 446     return 2 if dirname($p1) =~ /^\Q$p2/;
 447   }
 448   return 0;
 449 }
 450
 451
 452 # return real file name (from symlink)
 453 sub realfilename {
 454   my $file = shift;
 455
 456   return '' unless -e $file;
 457
 458   if (-l $file) {
 459     return realfilename(readlink($file));
 460   } else {
 461     return $file;
 462   }
 463 }
 464
 465
 466 sub security_check {
 467   my $file = shift; # can be directory, too!
 468   my @s;
 469
 470   # client ip allowed?
 471   access_check($file);
 472
 473   # documents with leading . are not allowed
 474   if (abs_path($file) =~ /\/\./) {
 475     errorlog("$file with leading .");
 476     http_error(403);
 477   }
 478
 479   if (-f $file) {
 480
 481     # document filename must not contain @
 482     if (realfilename($file) =~ /@/ or abs_path($file) =~ /@/) {
 483       errorlog("$file contains @");
 484       http_error(403);
 485     }
 486
 487     # document filename must not end with ~
 488     if (realfilename($file) =~ /~$/) {
 489       errorlog("$file ends with ~");
 490       http_error(403);
 491     }
 492
 493     # file must be group or world readable
 494     if (@s = stat($file) and not($s[2] & (S_IRGRP|S_IROTH))) {
 495       errorlog("$file not group or world readable");
 496       http_error(403);
 497     }
 498
 499     # symlink to regular file and symlink owned by root or fex? ==> ok!
 500     if (-l $file and path_match(dirname($file),$docdir)) {
 501       @s = lstat($file);
 502       return if $s[4] == 0 or $s[4] == $<;
 503     }
 504
 505   }
 506
 507   # file in allowed directory? ==> ok!
 508   foreach my $dir (@doc_dirs) {
 509     return if path_match($file,$dir);
 510   }
 511
 512   errorlog("$file not in \@doc_dirs");
 513   http_error(403);
 514 }
 515
 516 # security check: client ip allowed?
 517 sub access_check {
 518   my $file = abs_path(shift);
 519   my $dir = $file;
 520   my $af;
 521   local $_;
 522
 523   $dir .= '/x' if -d $dir;
 524
 525   while ($dir = dirname($dir) and $dir ne '/') {
 526     $af = "$dir/.htaccessfrom";
 527     if (open $af,$af) {
 528       while (<$af>) {
 529         s/\s//g;
 530         if (ipin($ra,$_)) {
 531           close $af;
 532           return;
 533         }
 534       }
 535       errorlog("no access to $file by $af");
 536       http_error(403);
 537     }
 538   }
 539
 540 }
 541
 542 # HTTP Basic authentication
 543 sub require_auth {
 544   my $htauth = shift;
 545   my $doc = shift;
 546   my ($realm,$auth);
 547   my @http_auth;
 548   my $uri = $ENV{REQUEST_URI} || '/';
 549
 550   $uri =~ s/\/index\.html$//;
 551   $uri =~ s/\/$//;
 552
 553   if (-d $doc or $doc =~ /\/index\.html$/) {
 554     $realm = $uri;
 555   } else {
 556     $realm = dirname($uri);
 557   }
 558
 559   $auth = slurp($htauth);
 560   unless ($auth and $realm) {
 561     http_header("200 OK");
 562     print html_header("$ENV{SERVER_NAME} no authentication");
 563     pq(qq(
 564       '<h3><code>$htauth</code> missing</h3>'
 565       '</body></html>'
 566     ));
 567     exit;
 568   }
 569   chomp $auth;
 570
 571   if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/)
 572   { @http_auth = split(':',decode_b64($1)) }
 573   if (@http_auth != 2 or $http_auth[1] ne $auth) {
 574     http_header(
 575       '401 Authorization Required',
 576       "WWW-Authenticate: Basic realm=\"$realm\"",
 577       'Content-Length: 0',
 578     );
 579     # control back to fexsrv for further HTTP handling
 580     &reexec;
 581   }
 582 }
 583
 584
 585 # function for <<perl-code>> inside HTML documents
 586 sub out {
 587   $__ .= join('',@_);
 588   return '';
 589 }
 590
 591 # tie STDOUT to buffer variable (redefining print)
 592 package Buffer;
 593
 594 sub TIEHANDLE {
 595   my ($class,$buffer) = @_;
 596   bless $buffer,$class;
 597 }
 598
 599 sub PRINT {
 600   my $buffer = shift;
 601   $$buffer .= $_ foreach @_;
 602 }
 603
 604 sub PRINTF {
 605   my $buffer = shift;
 606   my $fmt = shift @_;
 607   $$buffer .= sprintf($fmt,@_);
 608 }
 609
 610 1;