#!/usr/bin/perl -T

# fexsrv : web server for F*EX service
#
# Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
#

use 5.008;
use Socket;
use IO::Handle;
use Fcntl qw':flock :seek';
use warnings;

BEGIN {
  # stunnel workaround
  $SIG{CHLD} = "DEFAULT";
  $ENV{PERLINIT} = q{
    $ENV{LC_ALL} = 'en_US.UTF-8';
    unshift @INC,(getpwuid($<))[7].'/perl';
    # web error handler
    $SIG{__DIE__} = $SIG{__WARN__} = sub {
      my $info = '';
      my $url = $ENV{REQUEST_URL}||'';
      my @d = localtime time;
      my $time = sprintf('%d-%02d-%02d %02d:%02d:%02d',
                 $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]);
      if ($admin) {
        my $mailto = "mailto:$admin?subject=fex%20bug";
        $info = "<h3>send this error to <a href=\"$mailto\">$admin</a></h3>";
      }
      $_ = join("\n",@_);
      chomp;
      s/&/&amp;/g;
      s/</&lt;/g;
      $_ = join("\n",
        "<html><body>",
        "<h1>INTERNAL ERROR in $0</h1>",
        "<pre>\n$_\n</pre>\n<p>",
        "$url\n<p>",
        "$time\n<p>",
        "$info\n<p>",
        "</body></html>"
      );
      $length = length;
      unless ($HTTP_HEADER) {
        print "HTTP/1.0 200 ERROR\r\n";
        print "Content-Type: text/html\r\n";
        print "Content-Length: $length\r\n";
        print "\r\n";
      }
      print;
      exit 99;
    }
  };
  eval $ENV{PERLINIT};
}

# use BSD::Resource;
# setrlimit(RLIMIT_CPU,999,999) or die "$0: $!\n";

# SSL remote address provided by stunnel
if (@ARGV and $ARGV[0] eq 'stunnel' and $ENV{REMOTE_HOST} =~ /(.+)/) {
  $ssl_ra = $1;
}

# KEEP_ALIVE <== callback from CGI
if ($ENV{KEEP_ALIVE}) {
  $keep_alive = $ENV{KEEP_ALIVE};
} else {
  %ENV = ( PERLINIT => $ENV{PERLINIT} );   # clean environment
}

$ENV{HOME} = (getpwuid($<))[7] or die "no HOME";

# fexsrv MUST be run with full path!
if ($0 =~ m:^(/.+)/bin/fexsrv:) {
  $FEXHOME = $1;
  $FEXHOME =~ s:/+:/:g;
  $FEXHOME =~ s:/$::;
  $ENV{FEXHOME} = $FEXHOME;
}

foreach my $lib (
  $FEXHOME,
  '/usr/local/fex',
  '/usr/local/share/fex',
  '/usr/share/fex',
) {
  $ENV{FEXLIB} = $FEXLIB = $lib       and last if -f "$lib/fex.pp";
  $ENV{FEXLIB} = $FEXLIB = "$lib/lib" and last if -f "$lib/lib/fex.pp";
}

# import from fex.pp
our ($hostname,$debug,$timeout,$max_error,$max_error_handler);
our ($spooldir,@logdir,$docdir,$xkeydir,$akeydir,$lockdir);
our ($force_https,$default_locale,$bs,$MB,$adlm,@forbidden_user_agents);
our (@locales);

# load common code (local config: $FEXHOME/lib/fex.ph)
require "$FEXLIB/fex.pp" or die "cannot load $FEXLIB/fex.pp - $!\n";

chdir $spooldir or http_die("$0: $spooldir - $!\n");

our $log = 'fexsrv.log';
our $error = 'F*EX ERROR';
our $htmlsource;
our $hid = ''; # header ID
our @log;

$0 = untaint($0);

$ENV{GATEWAY_INTERFACE} = 'CGI/1.1f';
$ENV{SERVER_NAME} = $hostname;
$ENV{REQUEST_METHOD} = '';
$ENV{QUERY_STRING} = '';
$ENV{HTTP_COOKIE} = '';
$ENV{PATH_INFO} = '';
$ENV{RANDOM} = randstring(8);
$ENV{FEATURES} = join(',',qw(
  SID CHECKRECIPIENT GROUPS QUOTA FILEID MULTIPOST XKEY FILEQUERY FILESTREAM
  JUP NOSTORE AXEL FEXMAIL FILELINK
));

$port = 0;

# continue session?
if ($keep_alive) {
  if ($ENV{HTTP_HOST} =~ /(.+):(.+)/) {
    $hostname = $1;
    $port = $2;
  } else {
    $hostname = $ENV{HTTP_HOST};
    if ($ENV{PROTO} eq 'https') { $port = 443 }
    else                        { $port = 80 }
  }
  $ra = $ENV{REMOTE_ADDR};
  $rh = $ENV{REMOTE_HOST};
}

# new session
else {
  my $iaddr;

  # HTTPS connect
  if ($ssl_ra) {
    $ENV{PROTO} = 'https';
    $ENV{REMOTE_ADDR} = $ra = $ssl_ra;
    if ($ssl_ra =~ /[\w:]:\w/) {
      # ($rh) = `host $ssl_ra 2>/dev/null` =~ /name pointer (.+)\.$/;
      $^W = 0; eval 'use Socket6'; $^W = 1;
      http_error(503) if $@;
      $iaddr = inet_pton(AF_INET6,$ssl_ra) and
      $rh = gethostbyaddr($iaddr,AF_INET6);
    } else {
      $rh = gethostbyaddr(inet_aton($ra),AF_INET);
    }
    $rh ||= '-';
    $port = 443;
    # print {$log} "X-SSL-Remote-Host: $ssl_ra\n";
  }

  # HTTP connect
  else {
    $ENV{PROTO} = 'http';
    my $sa = getpeername(STDIN) or die "no network stream on STDIN\n";
    if (sockaddr_family($sa) == AF_INET) {
      ($ENV{REMOTE_PORT},$iaddr) = sockaddr_in($sa);
      $ENV{REMOTE_ADDR} = $ra = inet_ntoa($iaddr);
      $rh = gethostbyaddr($iaddr,AF_INET);
      ($port) = sockaddr_in(getsockname(STDIN));
    } elsif (sockaddr_family($sa) == AF_INET6) {
      $^W = 0; eval 'use Socket6'; $^W = 1;
      http_error(503) if $@;
      ($ENV{REMOTE_PORT},$iaddr) = unpack_sockaddr_in6($sa);
      $ENV{REMOTE_ADDR} = $ra = inet_ntop(AF_INET6,$iaddr);
      $rh = gethostbyaddr($iaddr,AF_INET6);
      ($port) = unpack_sockaddr_in6(getsockname(STDIN));
    } else {
      die "unknown IP version\n";
    }
    $port = 80 unless $port;
  }

  $ENV{REMOTE_HOST} = $rh || '';

  $ENV{HTTP_HOST} = ($port == 80 or $port == 443)
                  ? $hostname : "$hostname:$port";

  $ENV{PORT} = $port;
}

if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra) {
  $ENV{FEATURES} =~ s/SID,//;
}

if (@anonymous_upload and ipin($ra,@anonymous_upload)) {
  $ENV{FEATURES} .= ',ANONYMOUS';
}

$| = 1;

$SIG{CHLD} = "DEFAULT"; # stunnel workaround

$SIG{ALRM} = sub {
  # printf {$log} "\nTIMEOUT %s %s\n",isodate(time),$connect;
  if (@log) {
    debuglog('TIMEOUT',isodate(time));
    fexlog($connect,@log,"TIMEOUT");
  }
  exit;
};

REQUEST: while (*STDIN) {

  if (defined $ENV{REQUESTCOUNT}) { $ENV{REQUESTCOUNT}++ }
  else                            { $ENV{REQUESTCOUNT} = 0 }

  $connect = sprintf "%s:%s %s %s %s [%s_%s]",
                     $keep_alive ? 'CONTINUE' : 'CONNECT',
                     $port,
                     isodate(time),
                     $rh||'-',
                     $ra,
                     $$,$ENV{REQUESTCOUNT};
  $hid = sprintf("%s %s\n",$rh||'-',$ra);

  @header = @log = ();
  $header = '';

  # read complete HTTP header
  while (defined ($_ = &getaline)) {
    last if /^\s*$/;
    $hl += length;
    $header .= $_;
    s/[\r\n]+$//;
    # URL-encode non-printable chars
    s/([\x00-\x08\x0E-\x1F\x7F-\x9F])/sprintf "%%%02X",ord($1)/ge;
    s/%21/!/g;
    if (@header and s/^\s+/ /) {
      $header[-1] .= $_;
    } else {
      push @header,$_;
      $header{$1} = $2 if /(.+)\s*:\s*(.+)/;
      push @log,$_;
    }
    if ($hl > $MB) {
      fexlog($connect,@log,"OVERRUN");
      http_error(413);
    }

    if (/^(GET \/|\S*Forwarded|\S*Client-IP|\S*Coming-From|User-Agent)/i) {
      $hid .= $_."\n";
    }

    # reverse-proxy?
    # (only IPv4 support!)
    if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra and
       /^\S*(Forwarded|Client-IP|Coming-From)\S*: ([\da-f:.]+)/i
    ) {
      $ENV{REMOTE_ADDR} = $ra = $2;
      $ENV{REMOTE_HOST} = $rh = gethostbyaddr(inet_aton($ra),AF_INET) || '';
      $ENV{HTTP_HOST} = $hostname;
      if ($ENV{PROTO} eq 'https') { $port = 443 }
      else                        { $port = 80 }
    }
  }

  exit unless @header;
  exit if $header =~ /^\s*$/;

  $ENV{HTTP_HEADER} = $header;
  debuglog($header);
  # http_die("<pre>$header</pre>");

  $ENV{'HTTP_HEADER_LENGTH'} = $hl;
  $ENV{REQUEST_URI} = $uri = '';
  $cgi = '';

  # is it a HTTP-request at all?
  $request = shift @header;
  if ($request !~ /^(GET|HEAD|POST|OPTIONS).*HTTP\/\d\.\d$/i) {
    fexlog($connect,$request,"DISCONNECT: no HTTP request");
    badlog("no HTTP request: $request");
    exit;
  }

  if ($force_https and $port != 443
      and $request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
    $request = $2;
    nvt_print(
      "HTTP/1.1 301 Moved Permanently",
      "Location: https://$hostname$request",
      "Content-Length: 0",
      ""
    );
    fexlog($connect,@log);
    exit;
  }

  $request =~ s{^(GET|HEAD|POST) https?://$hostname(:\d+)?}{$1 }i;

  if ($request =~ m"^(GET|HEAD) /fop/\w+/") {
    # no header inquisition on regular fop request
    $header_hook = '';
  } else {
    &$header_hook($connect,$request,$ra) if $header_hook;
  }

  unless ($keep_alive) {
    if ($request =~ m:(HTTP/1.(\d)): and $2) {
      $ENV{KEEP_ALIVE} = $keep_alive = $ra
    } else {
      $ENV{KEEP_ALIVE} = $keep_alive = '';
    }
  }

  if ($request =~ /^OPTIONS \/?FEX HTTP\/[\d\.]+$/i) {
    fexlog($connect,@log);
    nvt_print(
      "HTTP/1.1 201 OK",
      "X-Features: $ENV{FEATURES}",
      "X-Timeout: $timeout",
      ''
    );
    next REQUEST if $keep_alive;
    exit;
  }

  if ($request =~ m:^GET /?SID HTTP/[\d\.]+$:i) {
    if ($ENV{FEATURES} !~ /\bSID\b/) {
      fexlog($connect,@log);
      nvt_print(
        "HTTP/1.1 501 Not Available",
        "Server: fexsrv",
        "X-Features: ".$ENV{FEATURES},
        "X-Timeout: ".$timeout,
        'Content-Length: 0',
        ''
      );
    } else {
      $ENV{SID} = randstring(8);
      fexlog($connect,@log);
      nvt_print(
        "HTTP/1.1 201 ".$ENV{SID},
        "Server: fexsrv",
        "X-Features: ".$ENV{FEATURES},
        "X-SID: ".$ENV{SID},
        "X-Timeout: ".$timeout,
        'Content-Length: 0',
        ''
      );
    }
    next REQUEST if $keep_alive;
    exit;
  }

  if ($request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
    $ENV{REQUEST}	 = $_;
    $ENV{REQUEST_METHOD} = uc($1);
    $ENV{REQUEST_URI}    = $uri = $cgi = $2;
    $ENV{HTTP_VERSION}   = $protocol = $3;
    $ENV{QUERY_STRING}   = $1               if $cgi =~ s/\?(.*)//;
    $ENV{PATH_INFO}      = $1               if $cgi =~ m:/.+?(/.+?)(\?|$):;
    $ENV{KEEP_ALIVE}     = $keep_alive = '' if $protocol =~ /1\.0/;
    $ENV{REQUEST_URL}    = "$ENV{PROTO}://$ENV{HTTP_HOST}$ENV{REQUEST_URI}";
    if ($uri =~ /<|%3c/i)  { badchar("&lt;") }
    if ($uri =~ />|%3e/i)  { badchar(">") }
    if ($uri =~ /\||%7c/i) { badchar("|") }
    if ($uri =~ /\\|%5c/i) { badchar("\\") }
  }

  my $fua = join('|',@forbidden_user_agents);

  while ($_ = shift @header) {

    # header inquisition!
    &$header_hook($connect,$_,$ra) if $header_hook;

    # mega stupid "Download Manager" FlashGet
    if ($uri =~ m{^/fop/} and m{^Referer: https?://.*\Q$uri$}) {
      fexlog($connect,@log,"NULL: FlashGet");
      debuglog("NULL: FlashGet");
      exec qw'cat /dev/zero' or sleep 30;
      exit;
    }

    if ($fua and /^User-Agent: ($fua)/) {
      disconnect($1,"499 User Agent $1 Not Supported",30);
    }

    if (/^Range:.*,/) {
      disconnect("Range a,b","416 Requested Range Not Satisfiable",30);
    }
    if (/^Range:.*(\d+)-(\d+)/) {
      if ($1 > $2) {
        disconnect("Range a>b","416 Requested Range Not Satisfiable",0);
      }
      if (($header{'User-Agent'}||'') !~ /$adlm/ ) {
        disconnect("Range a-b","416 Requested Range Not Satisfiable",30);
      }
    }

    if (/^Range:.*\d+-$/ and $hid) {
      my $lock = untaint($lockdir.'/'.md5_hex($hid));
      if (open $lock,'+>>',$lock) {
        if (flock($lock,LOCK_EX|LOCK_NB)) {
          seek $lock,0,0;
          truncate $lock,0;
          print {$lock} $hid;
        } else {
          disconnect(
            "multiple Range request",
            "400 Multiple Requests Not Allowed",
            10,
          );
        }
      }
    }

    # client signed int bug
    if (/^Range:.*-\d+-/) {
      disconnect("Range -a-","416 Requested Range Not Satisfiable",0);
    }

#    if (/^Range:/ and $protocol =~ /1\.0/) {
#      &$header_hook($connect,$_,$ra) while ($header_hook and $_ = shift @header);
#      fexlog($connect,@log,"DISCONNECT: Range + HTTP/1.0");
#      debuglog("DISCONNECT: Range + HTTP/1.0");
#      http_error(416);
#      exit;
#    }

    if (/^Connection:\s*close/i) {
      $ENV{KEEP_ALIVE} = $keep_alive = '';
    }

    # HTTP header ==> environment variables
    if (/^([\w\-_]+):\s*(.+)/s) {
      $http_var = $1;
      $http_val = $2;
      $http_var =~ s/-/_/g;
      $http_var = uc($http_var);
      $http_val =~ s/^\s+//;
      $http_val =~ s/\s+$//;
      if ($http_var =~ /^X_(FEX_\w+|CONTENT_LENGTH)$/) {
        $http_var = $1;
      } else {
        $http_val =~ s/\s+/ /g;
        if ($http_var =~ /^HTTP_(HOST|VERSION)$/) {
          $http_var = 'HTTP_X_'.$1;
        } elsif ($http_var =~ /^PROXY/) {
          # http://cert.at/warnings/all/20160718.html
          $http_var = 'HTTP_X_'.$http_var;
        } elsif ($http_var !~ /^CONTENT_/) {
          $http_var = 'HTTP_'.$http_var;
        }
      }
      $ENV{$http_var} = $http_val;
    }
  }

  # multiline header inquisition
  &$header_hook($connect,$header,$ra) if $header_hook;

  exit unless $cgi;

  # extra download request? (request http://fexserver//xkey)
  if ($cgi =~ m{^//([^/]+)$}) {
    my $xkey = $1;
    my $dkey;
    if ($xkey =~ /^afex_\d/) {
      $dkey = readlink "$xkeydir/$xkey" and $dkey =~ s/^\.\.\///;
    } else {
      $dkey = readlink "$xkeydir/$xkey/dkey" and $dkey .= "/$xkey";
    }
    if ($dkey) {
      # xkey downloads are only one time possible - besides afex
      if ($xkey !~ /^afex_\d/) {
        unlink "$xkeydir/$xkey/xkey";
        unlink "$xkeydir/$xkey";
      }
      nvt_print(
        "HTTP/1.1 301 Moved Permanently",
        "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fop/$dkey",
        "Content-Length: 0",
        ""
      );
      fexlog($connect,@log);
      exit;
    }
    fexlog($connect,@log);
    http_error(404);
    exit;
  }

  # get locale
  if (($ENV{QUERY_STRING} =~ /.*locale=([\w-]+)/ or
       $ENV{HTTP_COOKIE}  =~ /.*locale=([\w-]+)/)
      and -d "$FEXHOME/locale/$1") {
    $ENV{LOCALE} = $locale = $1;
  } else {
    $ENV{LOCALE} = $locale = $default_locale;
  }

  # for dynamic HTML documents
  if ($ENV{HTTP_COOKIE} =~ /akey=(\w+)/) {
    my $akey = $1;
    my ($user,$id);
    if ($user = readlink "$akeydir/$akey") {
      $user =~ s:.*/::;
      $user = untaint($user);
      if ($id = slurp("$spooldir/$user/@")) {
        chomp $id;
        $ENV{AKEY} = $akey;
        $ENV{USER} = $user;
        $ENV{ID}   = $id;
      }
    }
  }

  # check for name based virtual host
  $vhost = vhost($ENV{'HTTP_HOST'});

  if ($debug) {
    debuglog("ENV:\n");
    foreach $var (sort keys %ENV) {
      if (defined($ENV{$var})) {
        debuglog(sprintf "  %s = >%s<\n",$var,$ENV{$var});
      }
    }
    debuglog("\n");
  }

  # locale definitions in fex.ph?
  if (@locales) {
    if (@locales == 1) {
      $locale = $locales[0];
    } elsif (not grep /^$locale$/,@locales) {
      $locale = $default_locale;
    }
  }

  # prepare document file name
  if ($ENV{REQUEST_METHOD} =~ /^GET|HEAD$/) {
    if (%redirect) {
      foreach my $r (keys %redirect) {
        if ($uri =~ /^\Q$r/) {
          redirect($uri,$r);
          exit;
        }
      }
    }
    $doc = untaint($uri);
    $doc =~ s/%([\dA-F]{2})/unpack("a",pack("H2",$1))/ge;
    $doc =~ m:/\.\./: and http_error(403);
    $doc =~ s:^/+::;
    $doc =~ s/\?.*//;
    if ($locale and $locale ne 'english' and -e "$docdir/locale/$locale/$doc") {
      $doc = "$docdir/locale/$locale/$doc";
    } else {
      $doc = "$docdir/$doc";
    }
  }

  # CGI or document request?
  if ($cgi =~ s:^/+::) {
    $cgi =~ s:/.*::;
    unless ($cgi) {
      my $login = "$FEXHOME/cgi-bin/login";
      if (-x $login) {
        $cgi = untaint(readlink($login) || $login);
        $cgi =~ s:.*/::;
      }
    }

    $ENV{SCRIPT_NAME} = $cgi;

    # locale CGIs? (vhost comes already with own FEXLIB)
    if ($locale and $locale ne 'english'
        and -f "$FEXHOME/locale/$locale/cgi-bin/$cgi") {
      $ENV{SCRIPT_FILENAME} = $cgi = "$FEXHOME/locale/$locale/cgi-bin/$cgi";
      $ENV{FEXLIB} = $FEXLIB = "$FEXHOME/locale/$locale/lib" unless $vhost;
    } else {
      $ENV{SCRIPT_FILENAME} = $cgi = "$FEXHOME/cgi-bin/$cgi";
      $ENV{FEXLIB} = $FEXLIB = "$FEXHOME/lib" unless $vhost;
    }

    $status = '';
    if (-x $cgi and -f $cgi) {
      if (@forbidden_hosts and ipin($ra,@forbidden_hosts)) {
        fexlog($connect,@log,"FORBIDDEN");
        http_error(403);
      }
      unlink "$spooldir/.error/$ra";
      # push @log,"DEBUG: locale=$locale locales=(@locales)";
      fexlog($connect,@log,"EXEC $cgi");
      eval { local $^W = 0; exec $cgi };
      $status = "$! or bad interpreter";
      fexlog($connect,@log,"FAILED to exec $cgi : $status");
      http_error(555);
    } else {
      if (-f "$doc/.htindex") {
        require "$FEXLIB/dop";
        fexlog($connect,@log);

        showindex($doc);
        STDOUT->flush;
        next REQUEST if $keep_alive;
        exit;
      }
      if (-f "$doc/index.html") {
        # force redirect if trailing / is missing
        # this is mandatory for processing further HTTP request!
        if ($doc !~ m{/$}) {
          nvt_print(
            "HTTP/1.1 301 Moved Permanently",
            "Location: $ENV{REQUEST_URL}/",
            "Content-Length: 0",
            ""
          );
          fexlog($connect,@log);
          next REQUEST if $keep_alive;
          exit;
        }
        $doc .= '/index.html';
        $doc =~ s:/+:/:g;
      }
      $doc =~ s/#.*//; # ignore HTML anchors (stupid msnbot)

      # special request for F*EX UNIX clients
      if ($ENV{SCRIPT_NAME} eq 'xx.tar') {
        bintar(qw'fexget fexsend xx zz ezz');
      }
      if ($ENV{SCRIPT_NAME} eq 'sex.tar') {
        bintar(qw'sexsend sexget sexxx');
      }
      if ($ENV{SCRIPT_NAME} eq 'afex.tar') {
        bintar(qw'afex asex fexget fexsend sexsend sexget');
      }
      if ($ENV{SCRIPT_NAME} eq 'afs.tar') {
        bintar(qw'afex asex fexget fexsend xx sexsend sexget sexxx zz ezz');
      }
      # URL ends with ".html!" or ".html?!"
      if ($doc =~ s/(\.html)!$/$1/ or
          $doc =~ /\.html$/ and $ENV{'QUERY_STRING'} eq '!')
      { $htmlsource = $doc } else { $htmlsource = '' }

      if (-f $doc
          or $doc =~ /(.+)\.(tar|tgz|zip)$/ and lstat("$1.stream")
          or $doc =~ /(.+)\.tgz$/           and -f "$1.tar"
          or $doc =~ /(.+)\.gz$/            and -f $1)
      {
        unlink "$spooldir/.error/$ra";
        delete $ENV{SCRIPT_FILENAME};
        $ENV{DOCUMENT_FILENAME} = $doc;
        require "$FEXLIB/dop";
        fexlog($connect,@log);
        dop($doc);
        STDOUT->flush;
        next REQUEST if $keep_alive;
        exit;
      } elsif ($uri eq '/bunny') {
        fexlog($connect,@log);
        nvt_print(
          'HTTP/1.1 200 OK',
          'Server: fexsrv',
          "Content-Type: text/plain",
          '',
          '=:3',
        );
        exit;
      } elsif ($uri eq '/camel') {
        fexlog($connect,@log);
        nvt_print(
          'HTTP/1.1 200 OK',
          'Server: fexsrv',
          "Content-Type: text/plain",
          '',
        );
        local $/;
        print unpack('u',<DATA>);
        exit;
      } elsif (-e $cgi) {
        $status = 'not executable';
      }

    }

  }

  # neither document nor CGI ==> error

  if ($status) {
    fexlog($connect,@log,"FAILED to exec $cgi : $status");
    http_error(666);
  } else {
    fexlog($connect,@log,"UNKNOWN URL");
    badlog($request);
    http_error(404);
  }
  exit;
}


# read one text line unbuffered from STDIN
sub getaline {
  my $line = '';
  my $n = 0;
  my $c;

  alarm($timeout);

  # must use sysread to avoid perl line buffering
  # (later exec would destroy line buffer)
  while (sysread STDIN,$c,1) {
    $line .= $c;
    $n++;
    last if $c eq "\n";
    if ($n > $bs) {
      fexlog($connect,@log,$line,"OVERRUN");
      http_error(413);
    }
  }

  alarm(0);

  return $line;
}


sub fexlog {
  my @log = @_;

  foreach my $logdir (@logdir) {
    if (open $log,'>>',"$logdir/$log") {
      flock $log,LOCK_EX;
      seek $log,0,SEEK_END;
      print {$log} "\n",join("\n",@log),"\n";
      close $log;
    } else {
      http_die("$0: cannot write to $logdir/$log - $!\n");
    }
  }
}


sub badchar {
  my $bc = shift;

  fexlog($connect,@log,"DISCONNECT: bad characters in URL");
  debuglog("DISCONNECT: bad characters in URL $uri");
  badlog($request);
  http_die("\"$bc\" is not allowed in URL");
}


sub bintar {
  my $tmpdir = "$FEXHOME/tmp";
  my $fs = "$ENV{PROTO}://$ENV{HTTP_HOST}";

  if (chdir "$FEXHOME/bin") {
    fexlog($connect,@log);
    chdir $fstb if $fstb;
    mkdir $tmpdir;
    foreach my $f (@_) {
      copy($f,"$tmpdir/$f","s#fexserver = ''#fexserver = '$fs'#");
      chmod 0755,"$tmpdir/$f";
    }
    chdir $tmpdir or http_die("internal error: $tmpdir - $!");
    my $tar = `tar cf - @_ 2>/dev/null`;
    unlink @_;
    nvt_print(
      'HTTP/1.1 200 OK',
      'Server: fexsrv',
      "Content-Length: ".length($tar),
      "Content-Type: application/x-tar",
      '',
    );
    print $tar;
    exit;
  }
}


sub http_error {
  my $error = shift;
  my $URL = $ENV{REQUEST_URL}||'';
  my $URI = $ENV{REQUEST_URI}||'';

  if ($error eq 400) {
    http_error_header("400 Bad Request");
    nvt_print("Your request $URL is not acceptable.");
  } elsif ($error eq 403) {
    http_error_header("403 Forbidden");
    nvt_print("You have no permission to request $URL");
  } elsif ($error eq 404) {
    http_error_header("404 Not Found");
    nvt_print("The requested URI $URI was not found on this server.");
  } elsif ($error eq 413) {
    http_error_header("413 Payload Too Large");
    nvt_print("Your HTTP header is too large.");
  } elsif ($error eq 416) {
    http_error_header("416 Requested Range Not Satisfiable");
  } elsif ($error eq 503) {
    http_error_header("503 Service Unavailable");
    # nvt_print("No Perl ipv6 support on this server.");
  } else {
    http_error_header("555 Unknown Error");
    nvt_print("The requested URL $URL produced an internal error.");
  }
  nvt_print(
    "<hr>",
    "<address>fexsrv at <a href=\"/index.html\">$hostname:$port</a></address>",
    "</body></html>",
  );
  exit;
}


sub disconnect {
  my $info = shift;
  my $error = shift;
  my $wait = shift||0;

  # &$header_hook($connect,$_,$ra) while ($header_hook and $_ = shift @header);
  fexlog($connect,@log,"DISCONNECT: $info");
  debuglog("DISCONNECT: $info");
  errorlog("$ENV{REQUEST_URI} ==> $error");
  badlog("$ENV{REQUEST_URI} ==> $error ($info)");

  sleep $wait;
  nvt_print("HTTP/1.0 $error");
  exit;
}


sub http_error_header {
  my $error = shift;
  my $uri = $ENV{REQUEST_URI};

  errorlog("$uri ==> $error") if $uri;
  nvt_print(
    "HTTP/1.1 $error",
    "Connection: close",
    "Content-Type: text/html; charset=iso-8859-1",
    "",
    '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">',
    "<html>",
    "<head><title>$error</title></head>",
    "<body>",
    "<h1>$error</h1>",
  );
}


sub redirect {
  my $uri = shift;
  my $r = shift;
  my $rr = $redirect{$r};
  my $newurl;

  $uri =~ s/\Q$r//;

  if ($rr =~ s/^!//) {
    $newurl = $rr.$uri;
    nvt_print(
      "HTTP/1.1 301 Moved Permanently",
      "Location: $newurl",
      "Content-Length: 0",
      ""
    );
  } else {
    if ($rr =~ /^http/) {
      $newurl = $rr.$uri;
    } else {
      $newurl = "$ENV{PROTO}://$ENV{HTTP_HOST}$rr$uri";
    }

    http_header("200 OK");
    print html_header("$hostname page has moved");
    pq(qq(
      '<h3>Please use new URL: <a href="$newurl">$newurl</a></h3>'
      '</body></html>'
    ));
  }
  fexlog($connect,@log,"REDIRECT $newurl");
  if ($rr =~ /^http/) {
    exit;
  } else {
    &reexec;
  }
}


sub badlog {
  my $request = shift;
  my @n;
  my $ed = "$spooldir/.error";
  local $_;

  if (@ignore_error) {
    foreach (@ignore_error) {
      return if $request =~ /$_/;
    }
  }

  if ($ra and $max_error and $max_error_handler) {
    mkdir($ed) unless -d $ed;

    if (open $ra,"+>>$ed/$ra") {
      flock($ra,LOCK_EX);
      seek $ra,0,SEEK_SET;
      @n = <$ra>;
      printf {$ra} "%s %s\n",isodate(time),$request;
      close $ra;
      &$max_error_handler($ra,@n) if scalar(@n) > $max_error;
    }
  }
}


__END__
M("`@("`@("`@("`@("`@("`@("`@("`@("`@("`@("`@("PM)R(G+5P*("`@
M("`@("`@("`@("`@("`@("`@("`@("]@8&`M+B`@(&!<("`@("Q=+B`@("`@
M("`@("`@("`@("`@("`@("`L+BY?"B`@("`@("`@("`@("`@("`@("`@("`@
M+&`@("`@(&`B+B`@72X@("`@(&`N("`@("`@("`@("`@("`@7U]?+BY>(&!?
M)V`B(B(*("`@("`@("`@("`@("`@("`@("`@("`I("`@("`@("`G+"TG+2T@
M+B`@("!@+B`@("`@(%]?7RPN+2<@("XN("T@("`G("TP("Y?"B`@("`@("`@
M("`@+"X@("`@("`@("`@?%]?+"Y?("!?("`N+5\@("!<("`\("Y@(B<G)V`L
M7R`@("`@("`@+2!?("TN("`@("`@("<M+BX*("`@("`@("`@('P@(&8M+2TM
M+2TM+2<O("`@("!@)RTM+BXL("`@("`M("`@("`@("`@("T@("`@("`@("`@
M("`@("`G("XL7U\N7%\N)PH@("`@("`@("`@8"TM)R<G)R<G8"TM7"`@("`@
M("`@("`@("!@)RTM+B`@("`@("`@("`@("`@("`@("`@7RPN)RTM)R<*("`@
M("`@("`@("`@("`@("`@("`@("\@("`@("`@("`@("`@("`@("!@8#T@+2`@
M+2`@("!?+2`@7RXM)PH@("`@("`@("`@("`@("`@("`@("!\("`@("`@("`@
M("`@("`@("`@("`@("!?)V`@("`G)U\M+2<*("`@("`@("`@("`@("`@("`@
M("`@?"`@("`@("`@("`@("`@("`@("`O("`@?"T]+BXM+2<*("`@("`@("`@
M("`@("`@(%\@("`@("<N("`@("`@("`N7R`@(%\N+2=@)R`@(&!?7PH@("`@
M("`@("`@("`@("PG("`N("PG("TL3%]?+WP@(%P@8"<G+&\N("`@+5\@("`@
M)V`M+2X*("`@("`@("`@("`@("`@+BPG(BT@("`O("`@("`@("`@?"`@8'8@
M+R`N("PG8"TM+BXG7R`G+@H@("`@("`@("`@("`@("`@("TN+E\L)R`@("`@
M('P@("!\("`@)RTM+E]@("!?+R`@('P@("!\"B`@("`@("`@("`@("`@("`@
M("`@("`@("`@("=@8"<@6R`@("`@("`@("=@)R`@("`L+RXN+PH@("`@("`@
M("`@("`@("`@("`@("`@("`@('P@("`M+B<@("`@("`@("`@("`@("Y;("`@
M+PH@("`@("`@("`@("`@("`@("`@(%]?7U]?7RX@("`L.E]?7U]?7U]?7U]?
M7U]?7RQ@("PG"B`@("TM+2TM+2TM+2TM+2TM+2TM+2TM+2TM+2T@+2(M+2TM
M+2TM+2TM+2TM+2TM+2T]+0H@+2TM+2TM+2TM+2TM+2TM+2TM+2TM+2TM+2TM
6+2TM+2TM+2TM+2TM+2TM+2TM+2TM"@``
