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

use CGI::Carp	qw(fatalsToBrowser);
use Fcntl 	qw(:flock :seek :mode);
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:\.\./: and $link !~ /^:.+:$/) {
    $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",
      ""
    );
    exec($FEXHOME.'/bin/fexsrv') if $ENV{KEEP_ALIVE};
    exit; 
  }

  if (@wdd and $wdd and grep { $doc =~ /$_/ } @wdd) { &$wdd($doc) }

  my $dir = untaint(getcwd());
  chdir(dirname($doc));
  http_output($doc,$seek);
  chdir($dir);
}

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

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

  # security check: document filename must not contain @
  if ($file =~ /@/ or -l $file and readlink($file) =~ /@/) {
    http_error(403);
  }
  
  # security check: document filename must not end with ~
  if ($file =~ /~$/ or -l $file and readlink($file) =~ /~$/) {
    http_error(403);
  }
  
  # security check: file must be group readable
  if (@s = stat($file) and not($s[2] & S_IRGRP or not -r $file)) {
    http_error(403);
  }
  
  if (-f $file) {
    # normal file
    open $file,'<',$file or http_error(400);
  } elsif ($file =~ /(.+)\.(tar|tgz|zip)$/ 
           and @s = lstat($streamfile = "$1.stream") and $s[4] == $<)
  {
    # streaming file (only if it is owned by user fex)
    my $base = $file;
    $base =~ s:/[^/]+$::;
    chdir $base;
    if (-l $streamfile and readlink($streamfile) =~ /^:(.+):$/) {
      # special symlink pointer file for streaming
      @files = split(/:/,$1);
    } elsif (open $streamfile,$streamfile) {
      # special streaming file
      while (<$streamfile>) {
        chomp;
        push @files,$_;
      }
    } else {
      http_error(503);
    }
    close $streamfile;
    foreach (@files) {
      if (/\// or /\.\.\//) { 
        # absolute path or relative path with parent directory is not allowed
        http_error(403);
      }
      if (@s = stat($_) and not($s[2] & S_IRGRP) or not -r $_) { 
        # file must be readable by user and group
        http_error(403);
      }
    }
    http_error(416) if $ENV{HTTP_RANGE};
    close STDERR;
    if ($file =~ /\.tar$/) {
      open $file,'-|',qw(tar cf -),@files or http_error(503);
    } elsif ($file =~ /\.tgz$/) {
      open $file,'-|',qw(tar czf -),@files or http_error(503);
    } elsif ($file =~ /\.zip$/) {
      open $file,'-|',qw(zip -q -),@files or http_error(503);
    } else {
      http_error(400);
    }
  } else {
    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';
    }
  }

  # show sourcecode if URL ends with '?!'
  # to avoid this for a HTML file, simple do a: chmod o-r file
  if ($type eq 'text/html') {
    if ($htmlsource) {
      if ((stat($file))[2] & S_IROTH) {
        $type = 'text/plain';
      } else {
        http_error(403);
      }
    }
  } elsif ($ENV{'QUERY_STRING'} eq '!') {
    $type = 'text/plain';
  }
      
  
  if ($type eq 'text/html') {
    $seek = 0;
    local $^W = 0;
    local $/;
    $htmldoc = <$file>;
    while ($htmldoc =~ s/\n##.*?\n/\n/) {};
    # 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 #include
    while ($htmldoc =~ s/\n#include "(.*?)"/\n$mark/s) {
      my $file = $1;
      my $include = '';
      if (open $file,$file) {
        $include = <$file>;
        close $file;
      }
      $htmldoc =~ s/$mark/$include/;
    }
    # 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);
    $seek = 0;
  } else {
    if (@files) {
      $size = 0;
    } 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 {
    # streaming?
    if (@files) {
      nvt_print(
        'HTTP/1.1 200 OK',
        'Server: fexsrv',
        "Expires: 0",
        "Content-Type: $type",
        '',
      );
    } else {
      $file =~ m{/htdocs/(.+)};
      # Java (clients) needs Last-Modified header!
      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') {
    if ($type eq 'text/html') {
      alarm($timeout*10);
      print $htmldoc;
    } else {
      # binary data
      seek $file,$seek,0;
      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;
  exit if @files; # streaming end
  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 ||= '.';
  
  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 symlinks
#  $htmldoc .= "\n<pre>\n";
#  my $link;
#  foreach my $l (sort @links) {
#    if ($l =~ /$allowed/ and $link = readlink "$dir/$l" and $link =~ /^[^.\/]/) {
#      $htmldoc .= "$l -> <a href=\"$link\">$dir/$link</a>\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);

  if (defined $p1 and defined $p2) {
    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;
