#!/usr/bin/perl -wT

# F*EX document output
#
# is a subprogram of fexsrv! do not run it directly!
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#
# Copyright: GNU General Public License

use CGI::Carp	qw(fatalsToBrowser);
use Fcntl 	qw(:flock :seek);
use POSIX	qw(strftime locale_h);
use Cwd 	qw(getcwd abs_path);

our ($bs,$tmpdir); # import from fex.pp

my $log = "$logdir/dop.log";

# POSIX time format needed for HTTP header
setlocale(LC_TIME,'POSIX');

sub dop {
  my $doc = shift;
  my $source = shift;
  my $seek = 0;
  my ($link,$host,$path);
  
  our $error = 'F*EX document output ERROR';
  
  # reget?
  if ($ENV{HTTP_RANGE} and $ENV{HTTP_RANGE} =~ /^bytes=(\d+)-$/i) {
    $seek = $1;
  }

  # redirect on relative symlinks without ".." 
  if ($link = readlink($doc) and 
      $link !~ m:^/: and $link !~ m:\.\./:) {
    $path = $ENV{REQUEST_URI};
    $path =~ s:[^/]*$::;
    $doc = "$path/$link";
    $doc =~ s:/+:/:g;
    $doc =~ s:^/::;
    $host = $ENV{HTTP_HOST} || $hostname;
    nvt_print(
      "HTTP/1.1 301 Moved Permanently",
      "Location: $ENV{PROTO}://$host/$doc",
      ""
    );
    exit; 
  }

  if (-f $doc) {
    if (-r $doc) {
      my $dir = untaint(getcwd());
      chdir(dirname($doc));
      http_output($doc,$seek);
      chdir($dir);
    } else {
      http_error(403);
    }
  } else {
    http_error(404);
  }

}

sub http_output {
  my ($file,$seek) = @_;
  my ($filename,$size,$total_size);
  my ($data,$type);
  my ($var,$env,$con);
  my $htmldoc = '';
  my $s = 0;
  my $b = 0;
  my $http_client = $ENV{HTTP_USER_AGENT} || '';
  local $_;

  # consistency check: document must be in htdocs directory
  if ($file !~ m:/htdocs/:) { 
    http_error(555);
  }

  # security check: document must not be in lib or spool directory
  if (path_match($file,$FEXLIB) or path_match($file,$spooldir)) {
    http_error(403);
  }

  open $file,'<',$file or http_error(404);
  
  $type = 'application/octet-stream';
  if    ($file =~ /\.html$/)	{ $type = 'text/html' } 
  elsif ($file =~ /\.txt$/)	{ $type = 'text/plain' }
  elsif ($file =~ /\.css$/)	{ $type = 'text/css' }
  elsif ($file =~ /\.js$/)	{ $type = 'text/javascript' }
  elsif ($file =~ /\.ps$/)	{ $type = 'application/postscript' }
  elsif ($file =~ /\.pdf$/)	{ $type = 'application/pdf' }
  elsif ($file =~ /\.jpg$/)	{ $type = 'image/jpeg' }
  elsif ($file =~ /\.png$/)	{ $type = 'image/png' }
  elsif ($file =~ /\.gif$/)	{ $type = 'image/gif' }
  elsif ($file !~ /\.(tar|tgz|zip|jar|rar|arj|7z|bz2?|gz)$/) {
    my $qfile = untaint(abs_path($file));
    $qfile =~ s/([^\/\.\+\w!=,_-])/\\$1/g;
    $_ = `file $qfile`;
    if (/HTML/) {
      $type = 'text/html';
    } elsif (/text/i and not -x $file) {
      $type = 'text/plain';
    }
  }
  
  if ($type eq 'text/html' and $htmlsource and ((stat($file))[2] & 4)) {
    $type = 'text/plain';
  }
  
  if ($type eq 'text/html') {
    $seek = 0;
    local $^W = 0;
    local $/;
    $htmldoc = <$file>;
    # evaluate #if ... #else ... #elseif ... #endif blocks
    my $mark = randstring(16);
    while ($htmldoc =~ s/\n(#if\s+(.+?)\n.+?\n)#endif/\n$mark/s) {
      $_ = $1;
      # if block
      if (eval $2) {
        s/#if.*\n//;
        s/\n#else.*//s;
        $htmldoc =~ s/$mark/$_/;
      } else {
        # elseif blocks
        while (s/.*?\n#elseif\s+(.+?)\n//s) {
          if (eval $1) {
            s/\n#else.*//s;
            $htmldoc =~ s/$mark/$_/;
          }
        }
        # else block left?
        if ($htmldoc =~ /$mark/) {
          s/.*\n#else\s*\n//s or $_ = '';
          $htmldoc =~ s/$mark/$_/;
        }
      }
    };
    # evaluate <<perl-code>>
    while ($htmldoc =~ /<<(.+?)>>/s) {
      local $pc = $1;
      local $__ = '';
      tie *STDOUT => "Buffer",\$__;
      $__ .= eval $pc;
      untie *STDOUT;
      $htmldoc =~ s/<<(.+?)>>/$__/s;
    };
    # substitute $variable$ with value from environment
    while ($htmldoc =~ /\$([\w_]+)\$/) {
      $var = $1;
      $env = $ENV{$var} || '';
      $htmldoc =~ s/\$$var\$/$env/g;
    };
    $total_size = $size = $s = length($htmldoc);
  } else {
    $total_size = -s $file || 0;
    $size = $total_size - $seek;
  }

  if ($size < 0) {
    http_header('416 Requested Range Not Satisfiable');
    exit;
  }
  
  alarm($timeout*10);
  
  if ($seek) {
    my $range = sprintf("bytes %s-%s/%s",$seek,$total_size-1,$total_size);
    nvt_print(
      'HTTP/1.1 206 Partial Content',
      'Server: fexsrv',
      "Content-Length: $size",
      "Content-Range: $range",
      "Content-Type: $type",
      '',
    );
  } else {
    # Java (clients) needs Last-Modified header!
    $file =~ m{/htdocs/(.+)};
    my $date = glob("$FEXHOME/locale/*/htdocs/$1") ?
               strftime("%a, %d %b %Y %T GMT",gmtime(time)) :
               http_date($file);
    nvt_print(
      'HTTP/1.1 200 OK',
      'Server: fexsrv',
      "Last-Modified: $date",
      "Expires: 0",
      "Content-Length: $size",
      "Content-Type: $type",
      '',
    );
  }

  if ($ENV{REQUEST_METHOD} eq 'GET') {
    seek $file,$seek,0;
    if ($type eq 'text/html') {
      alarm($timeout*10);
      print $htmldoc;
    } else {
      # binary data
      while ($b = read($file,$data,$bs)) {
        $s += $b;      
        alarm($timeout*10);
        print $data or last;
      }
    }
    fdlog($log,$file,$s,$size) if $s;
  }
  
  alarm(0);
  close $file;
  return $s;
}


# show directory index
sub showindex {
  my $dir = shift;
  my ($htmldoc,$size);
  my @links = ();
  my @dirs = ();
  my @files = ();
  my $uri = $ENV{REQUEST_URI};
  my $allowed;
  local $_;
  
  $uri =~ s:/+$::;
  $dir =~ s:/+$::;
  
  open my $htindex,"$dir/.htindex" or http_error(403);
  
  # .htindex may contain listing regexp
  chomp ($allowed = <$htindex> || '.');
  close $htindex;
  $allowed = '.' unless $allowed;
  
  opendir $dir,$dir or http_error(503);
  while (defined($_ = readdir $dir)) {
    next if /^[.#]/ or /~$/;
    if    (-l "$dir/$_") { push @links,$_ }
    elsif (-d "$dir/$_") { push @dirs,$_ }
    elsif (-f "$dir/$_") { push @files,$_ }
  }
  closedir $dir;

  # parent directory listable?
  if ($uri =~ m:(/.+)/.+: and -f "$dir/../.htindex") {
    unshift @dirs,$1;
  }

  # first the (sub)directories
  $htmldoc = "<HTML>\n<h1>$uri/</h1>\n";
  foreach my $d (sort @dirs) {
    if ($d =~ m:^/: and -f "$d/.htindex") {
      $htmldoc .= "<h3><a href=\"$d/\">$d/</a></h3>\n";
    } elsif (-f "$dir/$d/.htindex") {
      $htmldoc .= "<h3><a href=\"$uri/$d/\">$uri/$d/</a></h3>\n";
    }
  }
  
  # then the files
  $htmldoc .= "\n<pre>\n";
  foreach my $f (sort @files) {
    if ($f =~ /$allowed/) {
      $htmldoc .= sprintf "%20s %20s <a href=\"%s/%s\">%s</a>\n",
                          isodate(mtime("$dir/$f")),
                          d3(-s "$dir/$f"||0),
                          $uri,urlencode($f),$f;
    }
  }
  $htmldoc .= "</pre>\n</HTML>\n";
  
  $size = length($htmldoc);
  nvt_print(
    'HTTP/1.1 200 OK',
    'Server: fexsrv',
    "Content-Length: $size",
    "Content-Type: text/html",
    '',
  );
  print $htmldoc;
  fdlog($log,"$dir/",$size,$size);
}


sub mtime {
  return (lstat shift)[9];
}


sub d3 {
  local $_ = shift;
  while (s/(\d)(\d\d\d\b)/$1,$2/) {};
  return $_;
}


sub http_date {
  my $file = shift;
  my @stat;
  
  if (@stat = stat($file)) {
    return strftime("%a, %d %b %Y %T GMT",gmtime($stat[9]));
  } else {
    return 0;
  }
}


sub path_match {
  my $p1 = abs_path(shift);
  my $p2 = abs_path(shift);

  return 1 if $p1          =~ /^\Q$p2/;
  return 2 if dirname($p1) =~ /^\Q$p2/;
  return 0;
}


# function for <<perl-code>> inside HTML documents
sub out {
  $__ .= join('',@_);
  return '';
}


# tie STDOUT to buffer variable (redefining print)
package Buffer;
sub TIEHANDLE { my ($class, $buffer) = @_; bless $buffer, $class; }
sub PRINT { my $buffer = shift; $$buffer .= $_ foreach @_; }
  
1;
