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