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