bin/fexsrv

   1 #!/usr/bin/perl -T
   2
   3 # fexsrv : web server for F*EX service
   4 #
   5 # Author: Ulli Horlacher <framstag@rus.uni-stuttgart.de>
   6 #
   7
   8 use 5.008;
   9 use Socket;
  10 use IO::Handle;
  11 use Fcntl qw':flock :seek';
  12 use warnings;
  13
  14 BEGIN {
  15   # stunnel workaround
  16   $SIG{CHLD} = "DEFAULT";
  17   $ENV{PERLINIT} = q{
  18     $ENV{LC_ALL} = 'en_US.UTF-8';
  19     unshift @INC,(getpwuid($<))[7].'/perl';
  20     # web error handler
  21     $SIG{__DIE__} = $SIG{__WARN__} = sub {
  22       my $info = '';
  23       my $url = $ENV{REQUEST_URL}||'';
  24       my @d = localtime time;
  25       my $time = sprintf('%d-%02d-%02d %02d:%02d:%02d',
  26                  $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]);
  27       if ($admin) {
  28         my $mailto = "mailto:$admin?subject=fex%20bug";
  29         $info = "<h3>send this error to <a href=\"$mailto\">$admin</a></h3>";
  30       }
  31       $_ = join("\n",@_);
  32       chomp;
  33       s/&/&amp;/g;
  34       s/</&lt;/g;
  35       $_ = join("\n",
  36         "<html><body>",
  37         "<h1>INTERNAL ERROR in $0</h1>",
  38         "<pre>\n$_\n</pre>\n<p>",
  39         "$url\n<p>",
  40         "$time\n<p>",
  41         "$info\n<p>",
  42         "</body></html>"
  43       );
  44       $length = length;
  45       unless ($HTTP_HEADER) {
  46         print "HTTP/1.0 200 ERROR\r\n";
  47         print "Content-Type: text/html\r\n";
  48         print "Content-Length: $length\r\n";
  49         print "\r\n";
  50       }
  51       print;
  52       exit 99;
  53     }
  54   };
  55   eval $ENV{PERLINIT};
  56 }
  57
  58 # use BSD::Resource;
  59 # setrlimit(RLIMIT_CPU,999,999) or die "$0: $!\n";
  60
  61 # SSL remote address provided by stunnel
  62 if (@ARGV and $ARGV[0] eq 'stunnel' and $ENV{REMOTE_HOST} =~ /(.+)/) {
  63   $ssl_ra = $1;
  64 }
  65
  66 # KEEP_ALIVE <== callback from CGI
  67 if ($ENV{KEEP_ALIVE}) {
  68   $keep_alive = $ENV{KEEP_ALIVE};
  69 } else {
  70   %ENV = ( PERLINIT => $ENV{PERLINIT} );   # clean environment
  71 }
  72
  73 $ENV{HOME} = (getpwuid($<))[7] or die "no HOME";
  74
  75 # fexsrv MUST be run with full path!
  76 if ($0 =~ m:^(/.+)/bin/fexsrv:) {
  77   $FEXHOME = $1;
  78   $FEXHOME =~ s:/+:/:g;
  79   $FEXHOME =~ s:/$::;
  80   $ENV{FEXHOME} = $FEXHOME;
  81 }
  82
  83 foreach my $lib (
  84   $FEXHOME,
  85   '/usr/local/fex',
  86   '/usr/local/share/fex',
  87   '/usr/share/fex',
  88 ) {
  89   $ENV{FEXLIB} = $FEXLIB = $lib       and last if -f "$lib/fex.pp";
  90   $ENV{FEXLIB} = $FEXLIB = "$lib/lib" and last if -f "$lib/lib/fex.pp";
  91 }
  92
  93 # import from fex.pp
  94 our ($hostname,$debug,$timeout,$max_error,$max_error_handler);
  95 our ($spooldir,@logdir,$docdir,$xkeydir,$akeydir,$lockdir);
  96 our ($force_https,$default_locale,$bs,$MB,$adlm,@forbidden_user_agents);
  97 our (@locales);
  98
  99 # load common code (local config: $FEXHOME/lib/fex.ph)
 100 require "$FEXLIB/fex.pp" or die "cannot load $FEXLIB/fex.pp - $!\n";
 101
 102 chdir $spooldir or http_die("$0: $spooldir - $!\n");
 103
 104 our $log = 'fexsrv.log';
 105 our $error = 'F*EX ERROR';
 106 our $htmlsource;
 107 our $hid = ''; # header ID
 108 our @log;
 109
 110 $0 = untaint($0);
 111
 112 $ENV{GATEWAY_INTERFACE} = 'CGI/1.1f';
 113 $ENV{SERVER_NAME} = $hostname;
 114 $ENV{REQUEST_METHOD} = '';
 115 $ENV{QUERY_STRING} = '';
 116 $ENV{HTTP_COOKIE} = '';
 117 $ENV{PATH_INFO} = '';
 118 $ENV{RANDOM} = randstring(8);
 119 $ENV{FEATURES} = join(',',qw(
 120   SID CHECKRECIPIENT GROUPS QUOTA FILEID MULTIPOST XKEY FILEQUERY FILESTREAM
 121   JUP NOSTORE AXEL FEXMAIL FILELINK
 122 ));
 123
 124 $port = 0;
 125
 126 # continue session?
 127 if ($keep_alive) {
 128   if ($ENV{HTTP_HOST} =~ /(.+):(.+)/) {
 129     $hostname = $1;
 130     $port = $2;
 131   } else {
 132     $hostname = $ENV{HTTP_HOST};
 133     if ($ENV{PROTO} eq 'https') { $port = 443 }
 134     else                        { $port = 80 }
 135   }
 136   $ra = $ENV{REMOTE_ADDR};
 137   $rh = $ENV{REMOTE_HOST};
 138 }
 139
 140 # new session
 141 else {
 142   my $iaddr;
 143
 144   # HTTPS connect
 145   if ($ssl_ra) {
 146     $ENV{PROTO} = 'https';
 147     $ENV{REMOTE_ADDR} = $ra = $ssl_ra;
 148     if ($ssl_ra =~ /[\w:]:\w/) {
 149       # ($rh) = `host $ssl_ra 2>/dev/null` =~ /name pointer (.+)\.$/;
 150       $^W = 0; eval 'use Socket6'; $^W = 1;
 151       http_error(503) if $@;
 152       $iaddr = inet_pton(AF_INET6,$ssl_ra) and
 153       $rh = gethostbyaddr($iaddr,AF_INET6);
 154     } else {
 155       $rh = gethostbyaddr(inet_aton($ra),AF_INET);
 156     }
 157     $rh ||= '-';
 158     $port = 443;
 159     # print {$log} "X-SSL-Remote-Host: $ssl_ra\n";
 160   }
 161
 162   # HTTP connect
 163   else {
 164     $ENV{PROTO} = 'http';
 165     my $sa = getpeername(STDIN) or die "no network stream on STDIN\n";
 166     if (sockaddr_family($sa) == AF_INET) {
 167       ($ENV{REMOTE_PORT},$iaddr) = sockaddr_in($sa);
 168       $ENV{REMOTE_ADDR} = $ra = inet_ntoa($iaddr);
 169       $rh = gethostbyaddr($iaddr,AF_INET);
 170       ($port) = sockaddr_in(getsockname(STDIN));
 171     } elsif (sockaddr_family($sa) == AF_INET6) {
 172       $^W = 0; eval 'use Socket6'; $^W = 1;
 173       http_error(503) if $@;
 174       ($ENV{REMOTE_PORT},$iaddr) = unpack_sockaddr_in6($sa);
 175       $ENV{REMOTE_ADDR} = $ra = inet_ntop(AF_INET6,$iaddr);
 176       $rh = gethostbyaddr($iaddr,AF_INET6);
 177       ($port) = unpack_sockaddr_in6(getsockname(STDIN));
 178     } else {
 179       die "unknown IP version\n";
 180     }
 181     $port = 80 unless $port;
 182   }
 183
 184   $ENV{REMOTE_HOST} = $rh || '';
 185
 186   $ENV{HTTP_HOST} = ($port == 80 or $port == 443)
 187                   ? $hostname : "$hostname:$port";
 188
 189   $ENV{PORT} = $port;
 190 }
 191
 192 if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra) {
 193   $ENV{FEATURES} =~ s/SID,//;
 194 }
 195
 196 if (@anonymous_upload and ipin($ra,@anonymous_upload)) {
 197   $ENV{FEATURES} .= ',ANONYMOUS';
 198 }
 199
 200 $| = 1;
 201
 202 $SIG{CHLD} = "DEFAULT"; # stunnel workaround
 203
 204 $SIG{ALRM} = sub {
 205   # printf {$log} "\nTIMEOUT %s %s\n",isodate(time),$connect;
 206   if (@log) {
 207     debuglog('TIMEOUT',isodate(time));
 208     fexlog($connect,@log,"TIMEOUT");
 209   }
 210   exit;
 211 };
 212
 213 REQUEST: while (*STDIN) {
 214
 215   if (defined $ENV{REQUESTCOUNT}) { $ENV{REQUESTCOUNT}++ }
 216   else                            { $ENV{REQUESTCOUNT} = 0 }
 217
 218   $connect = sprintf "%s:%s %s %s %s [%s_%s]",
 219                      $keep_alive ? 'CONTINUE' : 'CONNECT',
 220                      $port,
 221                      isodate(time),
 222                      $rh||'-',
 223                      $ra,
 224                      $$,$ENV{REQUESTCOUNT};
 225   $hid = sprintf("%s %s\n",$rh||'-',$ra);
 226
 227   @header = @log = ();
 228   $header = '';
 229
 230   # read complete HTTP header
 231   while (defined ($_ = &getaline)) {
 232     last if /^\s*$/;
 233     $hl += length;
 234     $header .= $_;
 235     s/[\r\n]+$//;
 236     # URL-encode non-printable chars
 237     s/([\x00-\x08\x0E-\x1F\x7F-\x9F])/sprintf "%%%02X",ord($1)/ge;
 238     s/%21/!/g;
 239     if (@header and s/^\s+/ /) {
 240       $header[-1] .= $_;
 241     } else {
 242       push @header,$_;
 243       $header{$1} = $2 if /(.+)\s*:\s*(.+)/;
 244       push @log,$_;
 245     }
 246     if ($hl > $MB) {
 247       fexlog($connect,@log,"OVERRUN");
 248       http_error(413);
 249     }
 250
 251     if (/^(GET \/|\S*Forwarded|\S*Client-IP|\S*Coming-From|User-Agent)/i) {
 252       $hid .= $_."\n";
 253     }
 254
 255     # reverse-proxy?
 256     # (only IPv4 support!)
 257     if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra and
 258        /^\S*(Forwarded|Client-IP|Coming-From)\S*: ([\da-f:.]+)/i
 259     ) {
 260       $ENV{REMOTE_ADDR} = $ra = $2;
 261       $ENV{REMOTE_HOST} = $rh = gethostbyaddr(inet_aton($ra),AF_INET) || '';
 262       $ENV{HTTP_HOST} = $hostname;
 263       if ($ENV{PROTO} eq 'https') { $port = 443 }
 264       else                        { $port = 80 }
 265     }
 266   }
 267
 268   exit unless @header;
 269   exit if $header =~ /^\s*$/;
 270
 271   $ENV{HTTP_HEADER} = $header;
 272   debuglog($header);
 273   # http_die("<pre>$header</pre>");
 274
 275   $ENV{'HTTP_HEADER_LENGTH'} = $hl;
 276   $ENV{REQUEST_URI} = $uri = '';
 277   $cgi = '';
 278
 279   # is it a HTTP-request at all?
 280   $request = shift @header;
 281   if ($request !~ /^(GET|HEAD|POST|OPTIONS).*HTTP\/\d\.\d$/i) {
 282     fexlog($connect,$request,"DISCONNECT: no HTTP request");
 283     badlog("no HTTP request: $request");
 284     exit;
 285   }
 286
 287   if ($force_https and $port != 443
 288       and $request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
 289     $request = $2;
 290     nvt_print(
 291       "HTTP/1.1 301 Moved Permanently",
 292       "Location: https://$hostname$request",
 293       "Content-Length: 0",
 294       ""
 295     );
 296     fexlog($connect,@log);
 297     exit;
 298   }
 299
 300   $request =~ s{^(GET|HEAD|POST) https?://$hostname(:\d+)?}{$1 }i;
 301
 302   if ($request =~ m"^(GET|HEAD) /fop/\w+/") {
 303     # no header inquisition on regular fop request
 304     $header_hook = '';
 305   } else {
 306     &$header_hook($connect,$request,$ra) if $header_hook;
 307   }
 308
 309   unless ($keep_alive) {
 310     if ($request =~ m:(HTTP/1.(\d)): and $2) {
 311       $ENV{KEEP_ALIVE} = $keep_alive = $ra
 312     } else {
 313       $ENV{KEEP_ALIVE} = $keep_alive = '';
 314     }
 315   }
 316
 317   if ($request =~ /^OPTIONS \/?FEX HTTP\/[\d\.]+$/i) {
 318     fexlog($connect,@log);
 319     nvt_print(
 320       "HTTP/1.1 201 OK",
 321       "X-Features: $ENV{FEATURES}",
 322       "X-Timeout: $timeout",
 323       ''
 324     );
 325     next REQUEST if $keep_alive;
 326     exit;
 327   }
 328
 329   if ($request =~ m:^GET /?SID HTTP/[\d\.]+$:i) {
 330     if ($ENV{FEATURES} !~ /\bSID\b/) {
 331       fexlog($connect,@log);
 332       nvt_print(
 333         "HTTP/1.1 501 Not Available",
 334         "Server: fexsrv",
 335         "X-Features: ".$ENV{FEATURES},
 336         "X-Timeout: ".$timeout,
 337         'Content-Length: 0',
 338         ''
 339       );
 340     } else {
 341       $ENV{SID} = randstring(8);
 342       fexlog($connect,@log);
 343       nvt_print(
 344         "HTTP/1.1 201 ".$ENV{SID},
 345         "Server: fexsrv",
 346         "X-Features: ".$ENV{FEATURES},
 347         "X-SID: ".$ENV{SID},
 348         "X-Timeout: ".$timeout,
 349         'Content-Length: 0',
 350         ''
 351       );
 352     }
 353     next REQUEST if $keep_alive;
 354     exit;
 355   }
 356
 357   if ($request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
 358     $ENV{REQUEST}        = $_;
 359     $ENV{REQUEST_METHOD} = uc($1);
 360     $ENV{REQUEST_URI}    = $uri = $cgi = $2;
 361     $ENV{HTTP_VERSION}   = $protocol = $3;
 362     $ENV{QUERY_STRING}   = $1               if $cgi =~ s/\?(.*)//;
 363     $ENV{PATH_INFO}      = $1               if $cgi =~ m:/.+?(/.+?)(\?|$):;
 364     $ENV{KEEP_ALIVE}     = $keep_alive = '' if $protocol =~ /1\.0/;
 365     $ENV{REQUEST_URL}    = "$ENV{PROTO}://$ENV{HTTP_HOST}$ENV{REQUEST_URI}";
 366     if ($uri =~ /<|%3c/i)  { badchar("&lt;") }
 367     if ($uri =~ />|%3e/i)  { badchar(">") }
 368     if ($uri =~ /\||%7c/i) { badchar("|") }
 369     if ($uri =~ /\\|%5c/i) { badchar("\\") }
 370   }
 371
 372   my $fua = join('|',@forbidden_user_agents);
 373
 374   while ($_ = shift @header) {
 375
 376     # header inquisition!
 377     &$header_hook($connect,$_,$ra) if $header_hook;
 378
 379     # mega stupid "Download Manager" FlashGet
 380     if ($uri =~ m{^/fop/} and m{^Referer: https?://.*\Q$uri$}) {
 381       fexlog($connect,@log,"NULL: FlashGet");
 382       debuglog("NULL: FlashGet");
 383       exec qw'cat /dev/zero' or sleep 30;
 384       exit;
 385     }
 386
 387     if ($fua and /^User-Agent: ($fua)/) {
 388       disconnect($1,"499 User Agent $1 Not Supported",30);
 389     }
 390
 391     if (/^Range:.*,/) {
 392       disconnect("Range a,b","416 Requested Range Not Satisfiable",30);
 393     }
 394     if (/^Range:.*(\d+)-(\d+)/) {
 395       if ($1 > $2) {
 396         disconnect("Range a>b","416 Requested Range Not Satisfiable",0);
 397       }
 398       if (($header{'User-Agent'}||'') !~ /$adlm/ ) {
 399         disconnect("Range a-b","416 Requested Range Not Satisfiable",30);
 400       }
 401     }
 402
 403     if (/^Range:.*\d+-$/ and $hid) {
 404       my $lock = untaint($lockdir.'/'.md5_hex($hid));
 405       if (open $lock,'+>>',$lock) {
 406         if (flock($lock,LOCK_EX|LOCK_NB)) {
 407           seek $lock,0,0;
 408           truncate $lock,0;
 409           print {$lock} $hid;
 410         } else {
 411           disconnect(
 412             "multiple Range request",
 413             "400 Multiple Requests Not Allowed",
 414             10,
 415           );
 416         }
 417       }
 418     }
 419
 420     # client signed int bug
 421     if (/^Range:.*-\d+-/) {
 422       disconnect("Range -a-","416 Requested Range Not Satisfiable",0);
 423     }
 424
 425 #    if (/^Range:/ and $protocol =~ /1\.0/) {
 426 #      &$header_hook($connect,$_,$ra) while ($header_hook and $_ = shift @header);
 427 #      fexlog($connect,@log,"DISCONNECT: Range + HTTP/1.0");
 428 #      debuglog("DISCONNECT: Range + HTTP/1.0");
 429 #      http_error(416);
 430 #      exit;
 431 #    }
 432
 433     if (/^Connection:\s*close/i) {
 434       $ENV{KEEP_ALIVE} = $keep_alive = '';
 435     }
 436
 437     # HTTP header ==> environment variables
 438     if (/^([\w\-_]+):\s*(.+)/s) {
 439       $http_var = $1;
 440       $http_val = $2;
 441       $http_var =~ s/-/_/g;
 442       $http_var = uc($http_var);
 443       $http_val =~ s/^\s+//;
 444       $http_val =~ s/\s+$//;
 445       if ($http_var =~ /^X_(FEX_\w+|CONTENT_LENGTH)$/) {
 446         $http_var = $1;
 447       } else {
 448         $http_val =~ s/\s+/ /g;
 449         if ($http_var =~ /^HTTP_(HOST|VERSION)$/) {
 450           $http_var = 'HTTP_X_'.$1;
 451         } elsif ($http_var =~ /^PROXY/) {
 452           # http://cert.at/warnings/all/20160718.html
 453           $http_var = 'HTTP_X_'.$http_var;
 454         } elsif ($http_var !~ /^CONTENT_/) {
 455           $http_var = 'HTTP_'.$http_var;
 456         }
 457       }
 458       $ENV{$http_var} = $http_val;
 459     }
 460   }
 461
 462   # multiline header inquisition
 463   &$header_hook($connect,$header,$ra) if $header_hook;
 464
 465   exit unless $cgi;
 466
 467   # extra download request? (request http://fexserver//xkey)
 468   if ($cgi =~ m{^//([^/]+)$}) {
 469     my $xkey = $1;
 470     my $dkey;
 471     if ($xkey =~ /^afex_\d/) {
 472       $dkey = readlink "$xkeydir/$xkey" and $dkey =~ s/^\.\.\///;
 473     } else {
 474       $dkey = readlink "$xkeydir/$xkey/dkey" and $dkey .= "/$xkey";
 475     }
 476     if ($dkey) {
 477       # xkey downloads are only one time possible - besides afex
 478       if ($xkey !~ /^afex_\d/) {
 479         unlink "$xkeydir/$xkey/xkey";
 480         unlink "$xkeydir/$xkey";
 481       }
 482       nvt_print(
 483         "HTTP/1.1 301 Moved Permanently",
 484         "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fop/$dkey",
 485         "Content-Length: 0",
 486         ""
 487       );
 488       fexlog($connect,@log);
 489       exit;
 490     }
 491     fexlog($connect,@log);
 492     http_error(404);
 493     exit;
 494   }
 495
 496   # get locale
 497   if (($ENV{QUERY_STRING} =~ /.*locale=([\w-]+)/ or
 498        $ENV{HTTP_COOKIE}  =~ /.*locale=([\w-]+)/)
 499       and -d "$FEXHOME/locale/$1") {
 500     $ENV{LOCALE} = $locale = $1;
 501   } else {
 502     $ENV{LOCALE} = $locale = $default_locale;
 503   }
 504
 505   # for dynamic HTML documents
 506   if ($ENV{HTTP_COOKIE} =~ /akey=(\w+)/) {
 507     my $akey = $1;
 508     my ($user,$id);
 509     if ($user = readlink "$akeydir/$akey") {
 510       $user =~ s:.*/::;
 511       $user = untaint($user);
 512       if ($id = slurp("$spooldir/$user/@")) {
 513         chomp $id;
 514         $ENV{AKEY} = $akey;
 515         $ENV{USER} = $user;
 516         $ENV{ID}   = $id;
 517       }
 518     }
 519   }
 520
 521   # check for name based virtual host
 522   $vhost = vhost($ENV{'HTTP_HOST'});
 523
 524   if ($debug) {
 525     debuglog("ENV:\n");
 526     foreach $var (sort keys %ENV) {
 527       if (defined($ENV{$var})) {
 528         debuglog(sprintf "  %s = >%s<\n",$var,$ENV{$var});
 529       }
 530     }
 531     debuglog("\n");
 532   }
 533
 534   # locale definitions in fex.ph?
 535   if (@locales) {
 536     if (@locales == 1) {
 537       $locale = $locales[0];
 538     } elsif (not grep /^$locale$/,@locales) {
 539       $locale = $default_locale;
 540     }
 541   }
 542
 543   # prepare document file name
 544   if ($ENV{REQUEST_METHOD} =~ /^GET|HEAD$/) {
 545     if (%redirect) {
 546       foreach my $r (keys %redirect) {
 547         if ($uri =~ /^\Q$r/) {
 548           redirect($uri,$r);
 549           exit;
 550         }
 551       }
 552     }
 553     $doc = untaint($uri);
 554     $doc =~ s/%([\dA-F]{2})/unpack("a",pack("H2",$1))/ge;
 555     $doc =~ m:/\.\./: and http_error(403);
 556     $doc =~ s:^/+::;
 557     $doc =~ s/\?.*//;
 558     if ($locale and $locale ne 'english' and -e "$docdir/locale/$locale/$doc") {
 559       $doc = "$docdir/locale/$locale/$doc";
 560     } else {
 561       $doc = "$docdir/$doc";
 562     }
 563   }
 564
 565   # CGI or document request?
 566   if ($cgi =~ s:^/+::) {
 567     $cgi =~ s:/.*::;
 568     unless ($cgi) {
 569       my $login = "$FEXHOME/cgi-bin/login";
 570       if (-x $login) {
 571         $cgi = untaint(readlink($login) || $login);
 572         $cgi =~ s:.*/::;
 573       }
 574     }
 575
 576     $ENV{SCRIPT_NAME} = $cgi;
 577
 578     # locale CGIs? (vhost comes already with own FEXLIB)
 579     if ($locale and $locale ne 'english'
 580         and -f "$FEXHOME/locale/$locale/cgi-bin/$cgi") {
 581       $ENV{SCRIPT_FILENAME} = $cgi = "$FEXHOME/locale/$locale/cgi-bin/$cgi";
 582       $ENV{FEXLIB} = $FEXLIB = "$FEXHOME/locale/$locale/lib" unless $vhost;
 583     } else {
 584       $ENV{SCRIPT_FILENAME} = $cgi = "$FEXHOME/cgi-bin/$cgi";
 585       $ENV{FEXLIB} = $FEXLIB = "$FEXHOME/lib" unless $vhost;
 586     }
 587
 588     $status = '';
 589     if (-x $cgi and -f $cgi) {
 590       if (@forbidden_hosts and ipin($ra,@forbidden_hosts)) {
 591         fexlog($connect,@log,"FORBIDDEN");
 592         http_error(403);
 593       }
 594       unlink "$spooldir/.error/$ra";
 595       # push @log,"DEBUG: locale=$locale locales=(@locales)";
 596       fexlog($connect,@log,"EXEC $cgi");
 597       eval { local $^W = 0; exec $cgi };
 598       $status = "$! or bad interpreter";
 599       fexlog($connect,@log,"FAILED to exec $cgi : $status");
 600       http_error(555);
 601     } else {
 602       if (-f "$doc/.htindex") {
 603         require "$FEXLIB/dop";
 604         fexlog($connect,@log);
 605
 606         showindex($doc);
 607         STDOUT->flush;
 608         next REQUEST if $keep_alive;
 609         exit;
 610       }
 611       if (-f "$doc/index.html") {
 612         # force redirect if trailing / is missing
 613         # this is mandatory for processing further HTTP request!
 614         if ($doc !~ m{/$}) {
 615           nvt_print(
 616             "HTTP/1.1 301 Moved Permanently",
 617             "Location: $ENV{REQUEST_URL}/",
 618             "Content-Length: 0",
 619             ""
 620           );
 621           fexlog($connect,@log);
 622           next REQUEST if $keep_alive;
 623           exit;
 624         }
 625         $doc .= '/index.html';
 626         $doc =~ s:/+:/:g;
 627       }
 628       $doc =~ s/#.*//; # ignore HTML anchors (stupid msnbot)
 629
 630       # special request for F*EX UNIX clients
 631       if ($ENV{SCRIPT_NAME} eq 'xx.tar') {
 632         bintar(qw'fexget fexsend xx zz ezz');
 633       }
 634       if ($ENV{SCRIPT_NAME} eq 'sex.tar') {
 635         bintar(qw'sexsend sexget sexxx');
 636       }
 637       if ($ENV{SCRIPT_NAME} eq 'afex.tar') {
 638         bintar(qw'afex asex fexget fexsend sexsend sexget');
 639       }
 640       if ($ENV{SCRIPT_NAME} eq 'afs.tar') {
 641         bintar(qw'afex asex fexget fexsend xx sexsend sexget sexxx zz ezz');
 642       }
 643       # URL ends with ".html!" or ".html?!"
 644       if ($doc =~ s/(\.html)!$/$1/ or
 645           $doc =~ /\.html$/ and $ENV{'QUERY_STRING'} eq '!')
 646       { $htmlsource = $doc } else { $htmlsource = '' }
 647
 648       if (-f $doc
 649           or $doc =~ /(.+)\.(tar|tgz|zip)$/ and lstat("$1.stream")
 650           or $doc =~ /(.+)\.tgz$/           and -f "$1.tar"
 651           or $doc =~ /(.+)\.gz$/            and -f $1)
 652       {
 653         unlink "$spooldir/.error/$ra";
 654         delete $ENV{SCRIPT_FILENAME};
 655         $ENV{DOCUMENT_FILENAME} = $doc;
 656         require "$FEXLIB/dop";
 657         fexlog($connect,@log);
 658         dop($doc);
 659         STDOUT->flush;
 660         next REQUEST if $keep_alive;
 661         exit;
 662       } elsif ($uri eq '/bunny') {
 663         fexlog($connect,@log);
 664         nvt_print(
 665           'HTTP/1.1 200 OK',
 666           'Server: fexsrv',
 667           "Content-Type: text/plain",
 668           '',
 669           '=:3',
 670         );
 671         exit;
 672       } elsif ($uri eq '/camel') {
 673         fexlog($connect,@log);
 674         nvt_print(
 675           'HTTP/1.1 200 OK',
 676           'Server: fexsrv',
 677           "Content-Type: text/plain",
 678           '',
 679         );
 680         local $/;
 681         print unpack('u',<DATA>);
 682         exit;
 683       } elsif (-e $cgi) {
 684         $status = 'not executable';
 685       }
 686
 687     }
 688
 689   }
 690
 691   # neither document nor CGI ==> error
 692
 693   if ($status) {
 694     fexlog($connect,@log,"FAILED to exec $cgi : $status");
 695     http_error(666);
 696   } else {
 697     fexlog($connect,@log,"UNKNOWN URL");
 698     badlog($request);
 699     http_error(404);
 700   }
 701   exit;
 702 }
 703
 704
 705 # read one text line unbuffered from STDIN
 706 sub getaline {
 707   my $line = '';
 708   my $n = 0;
 709   my $c;
 710
 711   alarm($timeout);
 712
 713   # must use sysread to avoid perl line buffering
 714   # (later exec would destroy line buffer)
 715   while (sysread STDIN,$c,1) {
 716     $line .= $c;
 717     $n++;
 718     last if $c eq "\n";
 719     if ($n > $bs) {
 720       fexlog($connect,@log,$line,"OVERRUN");
 721       http_error(413);
 722     }
 723   }
 724
 725   alarm(0);
 726
 727   return $line;
 728 }
 729
 730
 731 sub fexlog {
 732   my @log = @_;
 733
 734   foreach my $logdir (@logdir) {
 735     if (open $log,'>>',"$logdir/$log") {
 736       flock $log,LOCK_EX;
 737       seek $log,0,SEEK_END;
 738       print {$log} "\n",join("\n",@log),"\n";
 739       close $log;
 740     } else {
 741       http_die("$0: cannot write to $logdir/$log - $!\n");
 742     }
 743   }
 744 }
 745
 746
 747 sub badchar {
 748   my $bc = shift;
 749
 750   fexlog($connect,@log,"DISCONNECT: bad characters in URL");
 751   debuglog("DISCONNECT: bad characters in URL $uri");
 752   badlog($request);
 753   http_die("\"$bc\" is not allowed in URL");
 754 }
 755
 756
 757 sub bintar {
 758   my $tmpdir = "$FEXHOME/tmp";
 759   my $fs = "$ENV{PROTO}://$ENV{HTTP_HOST}";
 760
 761   if (chdir "$FEXHOME/bin") {
 762     fexlog($connect,@log);
 763     chdir $fstb if $fstb;
 764     mkdir $tmpdir;
 765     foreach my $f (@_) {
 766       copy($f,"$tmpdir/$f","s#fexserver = ''#fexserver = '$fs'#");
 767       chmod 0755,"$tmpdir/$f";
 768     }
 769     chdir $tmpdir or http_die("internal error: $tmpdir - $!");
 770     my $tar = `tar cf - @_ 2>/dev/null`;
 771     unlink @_;
 772     nvt_print(
 773       'HTTP/1.1 200 OK',
 774       'Server: fexsrv',
 775       "Content-Length: ".length($tar),
 776       "Content-Type: application/x-tar",
 777       '',
 778     );
 779     print $tar;
 780     exit;
 781   }
 782 }
 783
 784
 785 sub http_error {
 786   my $error = shift;
 787   my $URL = $ENV{REQUEST_URL}||'';
 788   my $URI = $ENV{REQUEST_URI}||'';
 789
 790   if ($error eq 400) {
 791     http_error_header("400 Bad Request");
 792     nvt_print("Your request $URL is not acceptable.");
 793   } elsif ($error eq 403) {
 794     http_error_header("403 Forbidden");
 795     nvt_print("You have no permission to request $URL");
 796   } elsif ($error eq 404) {
 797     http_error_header("404 Not Found");
 798     nvt_print("The requested URI $URI was not found on this server.");
 799   } elsif ($error eq 413) {
 800     http_error_header("413 Payload Too Large");
 801     nvt_print("Your HTTP header is too large.");
 802   } elsif ($error eq 416) {
 803     http_error_header("416 Requested Range Not Satisfiable");
 804   } elsif ($error eq 503) {
 805     http_error_header("503 Service Unavailable");
 806     # nvt_print("No Perl ipv6 support on this server.");
 807   } else {
 808     http_error_header("555 Unknown Error");
 809     nvt_print("The requested URL $URL produced an internal error.");
 810   }
 811   nvt_print(
 812     "<hr>",
 813     "<address>fexsrv at <a href=\"/index.html\">$hostname:$port</a></address>",
 814     "</body></html>",
 815   );
 816   exit;
 817 }
 818
 819
 820 sub disconnect {
 821   my $info = shift;
 822   my $error = shift;
 823   my $wait = shift||0;
 824
 825   # &$header_hook($connect,$_,$ra) while ($header_hook and $_ = shift @header);
 826   fexlog($connect,@log,"DISCONNECT: $info");
 827   debuglog("DISCONNECT: $info");
 828   errorlog("$ENV{REQUEST_URI} ==> $error");
 829   badlog("$ENV{REQUEST_URI} ==> $error ($info)");
 830
 831   sleep $wait;
 832   nvt_print("HTTP/1.0 $error");
 833   exit;
 834 }
 835
 836
 837 sub http_error_header {
 838   my $error = shift;
 839   my $uri = $ENV{REQUEST_URI};
 840
 841   errorlog("$uri ==> $error") if $uri;
 842   nvt_print(
 843     "HTTP/1.1 $error",
 844     "Connection: close",
 845     "Content-Type: text/html; charset=iso-8859-1",
 846     "",
 847     '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">',
 848     "<html>",
 849     "<head><title>$error</title></head>",
 850     "<body>",
 851     "<h1>$error</h1>",
 852   );
 853 }
 854
 855
 856 sub redirect {
 857   my $uri = shift;
 858   my $r = shift;
 859   my $rr = $redirect{$r};
 860   my $newurl;
 861
 862   $uri =~ s/\Q$r//;
 863
 864   if ($rr =~ s/^!//) {
 865     $newurl = $rr.$uri;
 866     nvt_print(
 867       "HTTP/1.1 301 Moved Permanently",
 868       "Location: $newurl",
 869       "Content-Length: 0",
 870       ""
 871     );
 872   } else {
 873     if ($rr =~ /^http/) {
 874       $newurl = $rr.$uri;
 875     } else {
 876       $newurl = "$ENV{PROTO}://$ENV{HTTP_HOST}$rr$uri";
 877     }
 878
 879     http_header("200 OK");
 880     print html_header("$hostname page has moved");
 881     pq(qq(
 882       '<h3>Please use new URL: <a href="$newurl">$newurl</a></h3>'
 883       '</body></html>'
 884     ));
 885   }
 886   fexlog($connect,@log,"REDIRECT $newurl");
 887   if ($rr =~ /^http/) {
 888     exit;
 889   } else {
 890     &reexec;
 891   }
 892 }
 893
 894
 895 sub badlog {
 896   my $request = shift;
 897   my @n;
 898   my $ed = "$spooldir/.error";
 899   local $_;
 900
 901   if (@ignore_error) {
 902     foreach (@ignore_error) {
 903       return if $request =~ /$_/;
 904     }
 905   }
 906
 907   if ($ra and $max_error and $max_error_handler) {
 908     mkdir($ed) unless -d $ed;
 909
 910     if (open $ra,"+>>$ed/$ra") {
 911       flock($ra,LOCK_EX);
 912       seek $ra,0,SEEK_SET;
 913       @n = <$ra>;
 914       printf {$ra} "%s %s\n",isodate(time),$request;
 915       close $ra;
 916       &$max_error_handler($ra,@n) if scalar(@n) > $max_error;
 917     }
 918   }
 919 }
 920
 921
 922 __END__
 923 M("`@("`@("`@("`@("`@("`@("`@("`@("`@("`@("`@("PM)R(G+5P*("`@
 924 M("`@("`@("`@("`@("`@("`@("`@("]@8&`M+B`@(&!<("`@("Q=+B`@("`@
 925 M("`@("`@("`@("`@("`@("`L+BY?"B`@("`@("`@("`@("`@("`@("`@("`@
 926 M+&`@("`@(&`B+B`@72X@("`@(&`N("`@("`@("`@("`@("`@7U]?+BY>(&!?
 927 M)V`B(B(*("`@("`@("`@("`@("`@("`@("`@("`I("`@("`@("`G+"TG+2T@
 928 M+B`@("!@+B`@("`@(%]?7RPN+2<@("XN("T@("`G("TP("Y?"B`@("`@("`@
 929 M("`@+"X@("`@("`@("`@?%]?+"Y?("!?("`N+5\@("!<("`\("Y@(B<G)V`L
 930 M7R`@("`@("`@+2!?("TN("`@("`@("<M+BX*("`@("`@("`@('P@(&8M+2TM
 931 M+2TM+2<O("`@("!@)RTM+BXL("`@("`M("`@("`@("`@("T@("`@("`@("`@
 932 M("`@("`G("XL7U\N7%\N)PH@("`@("`@("`@8"TM)R<G)R<G8"TM7"`@("`@
 933 M("`@("`@("!@)RTM+B`@("`@("`@("`@("`@("`@("`@7RPN)RTM)R<*("`@
 934 M("`@("`@("`@("`@("`@("`@("\@("`@("`@("`@("`@("`@("!@8#T@+2`@
 935 M+2`@("!?+2`@7RXM)PH@("`@("`@("`@("`@("`@("`@("!\("`@("`@("`@
 936 M("`@("`@("`@("`@("!?)V`@("`G)U\M+2<*("`@("`@("`@("`@("`@("`@
 937 M("`@?"`@("`@("`@("`@("`@("`@("`O("`@?"T]+BXM+2<*("`@("`@("`@
 938 M("`@("`@(%\@("`@("<N("`@("`@("`N7R`@(%\N+2=@)R`@(&!?7PH@("`@
 939 M("`@("`@("`@("PG("`N("PG("TL3%]?+WP@(%P@8"<G+&\N("`@+5\@("`@
 940 M)V`M+2X*("`@("`@("`@("`@("`@+BPG(BT@("`O("`@("`@("`@?"`@8'8@
 941 M+R`N("PG8"TM+BXG7R`G+@H@("`@("`@("`@("`@("`@("TN+E\L)R`@("`@
 942 M('P@("!\("`@)RTM+E]@("!?+R`@('P@("!\"B`@("`@("`@("`@("`@("`@
 943 M("`@("`@("`@("=@8"<@6R`@("`@("`@("=@)R`@("`L+RXN+PH@("`@("`@
 944 M("`@("`@("`@("`@("`@("`@('P@("`M+B<@("`@("`@("`@("`@("Y;("`@
 945 M+PH@("`@("`@("`@("`@("`@("`@(%]?7U]?7RX@("`L.E]?7U]?7U]?7U]?
 946 M7U]?7RQ@("PG"B`@("TM+2TM+2TM+2TM+2TM+2TM+2TM+2TM+2T@+2(M+2TM
 947 M+2TM+2TM+2TM+2TM+2T]+0H@+2TM+2TM+2TM+2TM+2TM+2TM+2TM+2TM+2TM
 948 6+2TM+2TM+2TM+2TM+2TM+2TM+2TM"@``