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>> or <<<perl-code>>>
 227     {
 228       local $timeout = '';
 229       local $SIG{ALRM} = sub { $timeout = '<h3>TIMEOUT!</h3>' };
 230       alarm(10);
 231       while ($htmldoc =~ /<<(.+?>?)>>/s) {
 232         local $pc = $1;
 233         if ($pc =~ s/^<(.+)>$/$1/) {
 234           # eval code without output substitution
 235           eval('package DOP;' . $pc);
 236           last if $timeout;
 237           $dynamic = $htmldoc =~ s/<<<(.+?)>>>//s;
 238         } else {
 239           # eval code with output substitution
 240           local $__ = '';
 241           tie *STDOUT => "Buffer",\$__;
 242           $__ .= eval('package DOP;' . $pc);
 243           untie *STDOUT;
 244           last if $timeout;
 245           $dynamic = $htmldoc =~ s/<<(.+?)>>/$__/s;
 246         }
 247       }
 248       alarm(0);
 249       $dynamic = $htmldoc =~ s/<<(.+?>?)>>/$timeout/sg if $timeout;
 250     }
 251     # substitute $variable$ with value from environment (if present)
 252     while ($htmldoc =~ /\$([\w_]+)\$/g) {
 253       $var = $1;
 254       if (defined($env = $ENV{$var})) {
 255         $htmldoc =~ s/\$$var\$/$env/g;
 256       }
 257     };
 258     $total_size = $size = $s = length($htmldoc);
 259   } else {
 260     if (@files) {
 261       $size = 0;
 262     } else {
 263       $total_size = -s $file || 0;
 264       $size = $total_size - $seek - ($stop ? $total_size-$stop-1 : 0);
 265     }
 266   }
 267
 268   if ($size < 0) {
 269     http_header('416 Requested Range Not Satisfiable');
 270     exit;
 271   }
 272
 273   alarm($timeout*10);
 274
 275   if ($seek or $stop) {
 276     my $range;
 277     if ($stop) {
 278       $range = sprintf("bytes %s-%s/%s",$seek,$stop,$total_size);
 279     } else {
 280       $range = sprintf("bytes %s-%s/%s",$seek,$total_size-1,$total_size);
 281     }
 282     nvt_print(
 283       'HTTP/1.1 206 Partial Content',
 284       'Server: fexsrv',
 285       "Content-Length: $size",
 286       "Content-Range: $range",
 287       "Content-Type: $type",
 288     );
 289   } else {
 290     # streaming?
 291     if (@files) {
 292       nvt_print(
 293         'HTTP/1.1 200 OK',
 294         'Server: fexsrv',
 295         "Expires: 0",
 296         "Content-Type: $type",
 297       );
 298     } else {
 299       # Java (clients) needs Last-Modified header!
 300       # if there are locale versions, use actual time for Last-Modified
 301       # to enforce reload of page
 302       $file =~ m{/htdocs/(.+)};
 303       my @lfiles = glob("$FEXHOME/locale/*/htdocs/$1");
 304       my $date = ($dynamic or @lfiles > 1) ?
 305                  strftime("%a, %d %b %Y %T GMT",gmtime(time)) :
 306                  http_date($file);
 307       nvt_print(
 308         'HTTP/1.1 200 OK',
 309         'Server: fexsrv',
 310         "Last-Modified: $date",
 311         "Expires: 0",
 312         "Content-Length: $size",
 313         "Content-Type: $type",
 314       );
 315       # nvt_print("Set-Cookie: locale=$locale") if $use_cookies and $locale;
 316     }
 317   }
 318   nvt_print($_) foreach(@extra_header);
 319   nvt_print('');
 320
 321   if ($ENV{REQUEST_METHOD} eq 'GET') {
 322     if ($type eq 'text/html') {
 323       alarm($timeout*10);
 324       print $htmldoc;
 325       $s = $size;
 326     } else {
 327       # binary data # can be stream!
 328       seek $file,$seek,0 if $seek;
 329       while ($b = read($file,$data,$bs)) {
 330         if ($stop and $s+$b > $size) {
 331           $b = $size-$s;
 332           $data = substr($data,0,$b)
 333         }
 334         $s += $b;
 335         alarm($timeout*10);
 336         print $data or last;
 337       }
 338     }
 339     fdlog($log,$file,$s,$size) if $s;
 340   }
 341
 342   alarm(0);
 343   close $file;
 344   exit if @files; # streaming end
 345   return $s;
 346 }
 347
 348
 349 # show directory index
 350 sub showindex {
 351   my $dir = shift;
 352   my ($htmldoc,$size);
 353   my @links = ();
 354   my @dirs = ();
 355   my @files = ();
 356   my $uri = $ENV{REQUEST_URI};
 357   my $allowed;
 358   my ($htindex,$htauth);
 359   local $_;
 360
 361   $uri =~ s:/+$::;
 362   $dir =~ s:/+$::;
 363
 364   security_check($dir);
 365
 366   $htindex = "$dir/.htindex";
 367   $htauth  = "$dir/.htauth";
 368
 369   open $htindex,$htindex or http_error(403);
 370   require_auth($htauth,$dir) if -f $htauth;
 371
 372   # .htindex may contain listing regexp
 373   chomp ($allowed = <$htindex>||'.');
 374   close $htindex;
 375
 376   opendir $dir,$dir or http_error(503);
 377   while (defined($_ = readdir $dir)) {
 378     next if /^[.#]/ or /~$/;
 379     if (@s = lstat "$dir/$_" and ($s[2] & (S_IRGRP|S_IROTH))) {
 380       if    (-l _) { push @links,$_ }
 381       elsif (-d _) { push @dirs,$_ }
 382       elsif (-f _) { push @files,$_ }
 383     }
 384   }
 385   closedir $dir;
 386
 387   # parent directory listable?
 388   if ($uri =~ m:(/.+)/.+: and -f "$dir/../.htindex") {
 389     unshift @dirs,$1;
 390   }
 391
 392   # first the (sub)directories
 393   $htmldoc = "<HTML>\n<h1>$uri/</h1>\n";
 394   foreach my $d (sort @dirs) {
 395     if ($d =~ m:^/: and -f "$d/.htindex") {
 396       $htmldoc .= "<h3><a href=\"$d/\">$d/</a></h3>\n";
 397     } elsif (-f "$dir/$d/.htindex") {
 398       $htmldoc .= "<h3><a href=\"$uri/$d/\">$uri/$d/</a></h3>\n";
 399     }
 400   }
 401
 402 #  # then the symlinks
 403 #  $htmldoc .= "\n<pre>\n";
 404 #  my $link;
 405 #  foreach my $l (sort @links) {
 406 #    if ($l =~ /$allowed/ and $link = readlink "$dir/$l" and $link =~ /^[^.\/]/) {
 407 #      $htmldoc .= "$l -> <a href=\"$link\">$dir/$link</a>\n";
 408 #    }
 409 #  }
 410
 411   # then the files
 412   $htmldoc .= "\n<pre>\n";
 413   foreach my $f (sort @files) {
 414     if ($f =~ /$allowed/) {
 415       $htmldoc .= sprintf "%20s %20s <a href=\"%s/%s\">%s</a>\n",
 416                           isodate(mtime("$dir/$f")),
 417                           d3(-s "$dir/$f"||0),
 418                           $uri,urlencode($f),$f;
 419     }
 420   }
 421   $htmldoc .= "</pre>\n</HTML>\n";
 422
 423   $size = length($htmldoc);
 424   nvt_print(
 425     'HTTP/1.1 200 OK',
 426     'Server: fexsrv',
 427     "Content-Length: $size",
 428     "Content-Type: text/html",
 429     '',
 430   );
 431   print $htmldoc;
 432   fdlog($log,"$dir/",$size,$size);
 433 }
 434
 435
 436 sub d3 {
 437   local $_ = shift;
 438   while (s/(\d)(\d\d\d\b)/$1,$2/) {};
 439   return $_;
 440 }
 441
 442
 443 sub http_date {
 444   my $file = shift;
 445   my @stat;
 446
 447   if (@stat = stat($file)) {
 448     return strftime("%a, %d %b %Y %T GMT",gmtime($stat[9]));
 449   } else {
 450     return 0;
 451   }
 452 }
 453
 454
 455 sub path_match {
 456   my $p1 = abs_path(shift);
 457   my $p2 = abs_path(shift);
 458
 459   if (defined $p1 and defined $p2) {
 460     return 1 if $p1          =~ /^\Q$p2/;
 461     return 2 if dirname($p1) =~ /^\Q$p2/;
 462   }
 463   return 0;
 464 }
 465
 466
 467 # return real file name (from symlink)
 468 sub realfilename {
 469   my $file = shift;
 470
 471   return '' unless -e $file;
 472
 473   if (-l $file) {
 474     return realfilename(readlink($file));
 475   } else {
 476     return $file;
 477   }
 478 }
 479
 480
 481 sub security_check {
 482   my $file = shift; # can be directory, too!
 483   my @s;
 484
 485   # client ip allowed?
 486   access_check($file);
 487
 488   # documents with leading . are not allowed
 489   if (abs_path($file) =~ /\/\./) {
 490     errorlog("$file with leading .");
 491     http_error(403);
 492   }
 493
 494   if (-f $file) {
 495
 496     # document filename must not contain @
 497     if (realfilename($file) =~ /@/ or abs_path($file) =~ /@/) {
 498       errorlog("$file contains @");
 499       http_error(403);
 500     }
 501
 502     # document filename must not end with ~
 503     if (realfilename($file) =~ /~$/) {
 504       errorlog("$file ends with ~");
 505       http_error(403);
 506     }
 507
 508     # file must be group or world readable
 509     if (@s = stat($file) and not($s[2] & (S_IRGRP|S_IROTH))) {
 510       errorlog("$file not group or world readable");
 511       http_error(403);
 512     }
 513
 514     # symlink to regular file and symlink owned by root or fex? ==> ok!
 515     if (-l $file and path_match(dirname($file),$docdir)) {
 516       @s = lstat($file);
 517       return if $s[4] == 0 or $s[4] == $<;
 518     }
 519
 520   }
 521
 522   # file in allowed directory? ==> ok!
 523   foreach my $dir (@doc_dirs) {
 524     return if path_match($file,$dir);
 525   }
 526
 527   errorlog("$file not in \@doc_dirs");
 528   http_error(403);
 529 }
 530
 531 # security check: client ip allowed?
 532 sub access_check {
 533   my $file = abs_path(shift);
 534   my $dir = $file;
 535   my $af;
 536   local $_;
 537
 538   $dir .= '/x' if -d $dir;
 539
 540   while ($dir = dirname($dir) and $dir ne '/') {
 541     $af = "$dir/.htaccessfrom";
 542     if (open $af,$af) {
 543       while (<$af>) {
 544         s/\s//g;
 545         if (ipin($ra,$_)) {
 546           close $af;
 547           return;
 548         }
 549       }
 550       errorlog("no access to $file by $af");
 551       http_error(403);
 552     }
 553   }
 554
 555 }
 556
 557 # HTTP Basic authentication
 558 sub require_auth {
 559   my $htauth = shift;
 560   my $doc = shift;
 561   my ($realm,$auth);
 562   my @http_auth;
 563   my $uri = $ENV{REQUEST_URI} || '/';
 564
 565   $uri =~ s/\/index\.html$//;
 566   $uri =~ s/\/$//;
 567
 568   if (-d $doc or $doc =~ /\/index\.html$/) {
 569     $realm = $uri;
 570   } else {
 571     $realm = dirname($uri);
 572   }
 573
 574   $auth = slurp($htauth);
 575   unless ($auth and $realm) {
 576     http_header("200 OK");
 577     print html_header("$ENV{SERVER_NAME} no authentication");
 578     pq(qq(
 579       '<h3><code>$htauth</code> missing</h3>'
 580       '</body></html>'
 581     ));
 582     exit;
 583   }
 584   chomp $auth;
 585
 586   if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/)
 587   { @http_auth = split(':',decode_b64($1)) }
 588   if (@http_auth != 2 or $http_auth[1] ne $auth) {
 589     http_header(
 590       '401 Authorization Required',
 591       "WWW-Authenticate: Basic realm=\"$realm\"",
 592       'Content-Length: 0',
 593     );
 594     # control back to fexsrv for further HTTP handling
 595     &reexec;
 596   }
 597 }
 598
 599
 600 # function for <<perl-code>> inside HTML documents
 601 sub out {
 602   $__ .= join('',@_);
 603   return '';
 604 }
 605
 606 # tie STDOUT to buffer variable (redefining print)
 607 package Buffer;
 608
 609 sub TIEHANDLE {
 610   my ($class,$buffer) = @_;
 611   bless $buffer,$class;
 612 }
 613
 614 sub PRINT {
 615   my $buffer = shift;
 616   $$buffer .= $_ foreach @_;
 617 }
 618
 619 sub PRINTF {
 620   my $buffer = shift;
 621   my $fmt = shift @_;
 622   $$buffer .= sprintf($fmt,@_);
 623 }
 624
 625 1;