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