#!/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);

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 $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) {
      http_output($doc,$seek);
    } else {
      http_error(403);
    }
  } else {
    http_error(404);
  }

}

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

  # security check: document must be in htdocs directory
  if ($file !~ m:/htdocs/:) { http_error(555) }
  
  open $file,'<',$file or http_error(404);
  
  $type = 'application/octet-stream';
  if    ($file =~ /\.html$/)	{ $type = 'text/html' } 
  elsif ($file =~ /\.css$/)	{ $type = 'text/css' }
  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 !~ /\.(zip|jar|rar|7z|gz)$/) {
    my $qfile = $file;
    $qfile =~ s/([^\/\.\+\w!=,_-])/\\$1/g;
    $_ = `file -L $qfile`;
    if (/text/i and not /executable/) {
      $type = 'text/plain';
    }
  }
  
  if ($type eq 'text/html') {
    $seek = 0;
    local $^W = 0;
    local $/;
    $htmldoc = <$file>;
    # evaluate <<perl-code>>
    while ($htmldoc =~ /<<(.+?)>>/s) {
      local $pc = $1;
      local $__ = '';
      tie *STDOUT => "Buffer", \$__;
      $__ .= eval $pc;
      untie *STDOUT;
      $htmldoc =~ s/<<(.+?)>>/$__/s;
    };
    # evaluate $variables$ 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;
  }
}


# 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;
