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,$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 \/|X-Forwarded-For|User-Agent)/i) {
 251       $hid .= $_."\n";
 252     }
 253
 254     # reverse-proxy?
 255     if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra and
 256        /^X-Forwarded-For: ([\d.]+)/
 257     ) {
 258       $ENV{REMOTE_ADDR} = $ra = $1;
 259       $ENV{REMOTE_HOST} = $rh = gethostbyaddr(inet_aton($ra),AF_INET) || '';
 260       $ENV{HTTP_HOST} = $hostname;
 261       if ($ENV{PROTO} eq 'https') { $port = 443 }
 262       else                        { $port = 80 }
 263     }
 264   }
 265
 266   exit unless @header;
 267   exit if $header =~ /^\s*$/;
 268
 269   $ENV{HTTP_HEADER} = $header;
 270   debuglog($header);
 271   # http_die("<pre>$header</pre>");
 272
 273   $ENV{'HTTP_HEADER_LENGTH'} = $hl;
 274   $ENV{REQUEST_URI} = $uri = '';
 275   $cgi = '';
 276
 277   # is it a HTTP-request at all?
 278   $request = shift @header;
 279   if ($request !~ /^(GET|HEAD|POST|OPTIONS).*HTTP\/\d\.\d$/i) {
 280     fexlog($connect,$request,"DISCONNECT: no HTTP request");
 281     badlog("no HTTP request: $request");
 282     exit;
 283   }
 284
 285   if ($force_https and $port != 443
 286       and $request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
 287     $request = $2;
 288     nvt_print(
 289       "HTTP/1.1 301 Moved Permanently",
 290       "Location: https://$hostname$request",
 291       "Content-Length: 0",
 292       ""
 293     );
 294     fexlog($connect,@log);
 295     exit;
 296   }
 297
 298   $request =~ s{^(GET|HEAD|POST) https?://$hostname(:\d+)?}{$1 }i;
 299
 300   if ($request =~ m"^(GET|HEAD) /fop/\w+/") {
 301     # no header inquisition on regular fop request
 302     $header_hook = '';
 303   } else {
 304     &$header_hook($connect,$request,$ra) if $header_hook;
 305   }
 306
 307   unless ($keep_alive) {
 308     if ($request =~ m:(HTTP/1.(\d)): and $2) {
 309       $ENV{KEEP_ALIVE} = $keep_alive = $ra
 310     } else {
 311       $ENV{KEEP_ALIVE} = $keep_alive = '';
 312     }
 313   }
 314
 315   if ($request =~ /^OPTIONS FEX HTTP\/[\d\.]+$/i) {
 316     fexlog($connect,@log);
 317     nvt_print(
 318       "HTTP/1.1 201 OK",
 319       "X-Features: $ENV{FEATURES}",
 320       "X-Timeout: $timeout",
 321       ''
 322     );
 323     next REQUEST if $keep_alive;
 324     exit;
 325   }
 326
 327   if ($request =~ m:^GET /?SID HTTP/[\d\.]+$:i) {
 328     if ($ENV{FEATURES} !~ /\bSID\b/) {
 329       fexlog($connect,@log);
 330       nvt_print(
 331         "HTTP/1.1 501 Not Available",
 332         "Server: fexsrv",
 333         "X-Features: ".$ENV{FEATURES},
 334         "X-Timeout: ".$timeout,
 335         'Content-Length: 0',
 336         ''
 337       );
 338     } else {
 339       $ENV{SID} = randstring(8);
 340       fexlog($connect,@log);
 341       nvt_print(
 342         "HTTP/1.1 201 ".$ENV{SID},
 343         "Server: fexsrv",
 344         "X-Features: ".$ENV{FEATURES},
 345         "X-SID: ".$ENV{SID},
 346         "X-Timeout: ".$timeout,
 347         'Content-Length: 0',
 348         ''
 349       );
 350     }
 351     next REQUEST if $keep_alive;
 352     exit;
 353   }
 354
 355   if ($request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
 356     $ENV{REQUEST}        = $_;
 357     $ENV{REQUEST_METHOD} = uc($1);
 358     $ENV{REQUEST_URI}    = $uri = $cgi = $2;
 359     $ENV{HTTP_VERSION}   = $protocol = $3;
 360     $ENV{QUERY_STRING}   = $1               if $cgi =~ s/\?(.*)//;
 361     $ENV{PATH_INFO}      = $1               if $cgi =~ m:/.+?(/.+?)(\?|$):;
 362     $ENV{KEEP_ALIVE}     = $keep_alive = '' if $protocol =~ /1\.0/;
 363     $ENV{REQUEST_URL}    = "$ENV{PROTO}://$ENV{HTTP_HOST}$ENV{REQUEST_URI}";
 364     if ($uri =~ /<|%3c/i)  { badchar("&lt;") }
 365     if ($uri =~ />|%3e/i)  { badchar(">") }
 366     if ($uri =~ /\||%7c/i) { badchar("|") }
 367     if ($uri =~ /\\|%5c/i) { badchar("\\") }
 368   }
 369
 370   while ($_ = shift @header) {
 371
 372     # header inquisition!
 373     &$header_hook($connect,$_,$ra) if $header_hook;
 374
 375     # mega stupid "Download Manager" FlashGet
 376     if ($uri =~ m{^/fop/} and m{^Referer: https?://.*\Q$uri$}) {
 377       fexlog($connect,@log,"NULL: FlashGet");
 378       debuglog("NULL: FlashGet");
 379       exec qw'cat /dev/zero' or sleep 30;
 380       exit;
 381     }
 382
 383     if ($header =~ /\nRange:/ and /^User-Agent: (FDM)/) {
 384       disconnect($1,"499 Download Manager $1 Not Supported",30);
 385     }
 386
 387     if (/^User-Agent: (Java\/[\d\.]+)/) {
 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 = 'X-'.$http_var;
 451         } elsif ($http_var !~ /^CONTENT_/) {
 452           $http_var = 'HTTP_'.$http_var;
 453         }
 454       }
 455       $ENV{$http_var} = $http_val;
 456     }
 457   }
 458
 459   # multiline header inquisition
 460   &$header_hook($connect,$header,$ra) if $header_hook;
 461
 462   exit unless $cgi;
 463
 464   # extra download request? (request http://fexserver//xkey)
 465   if ($cgi =~ m{^//([^/]+)$}) {
 466     my $xkey = $1;
 467     my $dkey;
 468     if ($xkey =~ /^afex_\d/) {
 469       $dkey = readlink "$xkeydir/$xkey" and $dkey =~ s/^\.\.\///;
 470     } else {
 471       $dkey = readlink "$xkeydir/$xkey/dkey" and $dkey .= "/$xkey";
 472     }
 473     if ($dkey) {
 474       # xkey downloads are only one time possible - besides afex
 475       if ($xkey !~ /^afex_\d/) {
 476         unlink "$xkeydir/$xkey/xkey";
 477         unlink "$xkeydir/$xkey";
 478       }
 479       nvt_print(
 480         "HTTP/1.1 301 Moved Permanently",
 481         "Location: $ENV{PROTO}://$ENV{HTTP_HOST}/fop/$dkey",
 482         "Content-Length: 0",
 483         ""
 484       );
 485       fexlog($connect,@log);
 486       exit;
 487     }
 488     fexlog($connect,@log);
 489     http_error(404);
 490     exit;
 491   }
 492
 493   # get locale
 494   if (($ENV{QUERY_STRING} =~ /.*locale=([\w-]+)/ or
 495        $ENV{HTTP_COOKIE}  =~ /.*locale=([\w-]+)/)
 496       and -d "$FEXHOME/locale/$1") {
 497     $ENV{LOCALE} = $locale = $1;
 498   } else {
 499     $ENV{LOCALE} = $locale = $default_locale;
 500   }
 501
 502   # check for name based virtual host
 503   $vhost = vhost($ENV{'HTTP_HOST'});
 504
 505   if ($debug) {
 506     debuglog("ENV:\n");
 507     foreach $var (sort keys %ENV) {
 508       if (defined($ENV{$var})) {
 509         debuglog(sprintf "  %s = >%s<\n",$var,$ENV{$var});
 510       }
 511     }
 512     debuglog("\n");
 513   }
 514
 515   # locale definitions in fex.ph?
 516   if (@locales) {
 517     if (@locales == 1) {
 518       $locale = $locales[0];
 519     } elsif (not grep /^$locale$/,@locales) {
 520       $locale = $default_locale;
 521     }
 522   }
 523
 524   # prepare document file name
 525   if ($ENV{REQUEST_METHOD} =~ /^GET|HEAD$/) {
 526     if (%redirect) {
 527       foreach my $r (keys %redirect) {
 528         if ($uri =~ /^\Q$r/) {
 529           redirect($uri,$r);
 530           exit;
 531         }
 532       }
 533     }
 534     $doc = untaint($uri);
 535     $doc =~ s/%([\dA-F]{2})/unpack("a",pack("H2",$1))/ge;
 536     $doc =~ m:/\.\./: and http_error(403);
 537     $doc =~ s:^/+::;
 538     $doc =~ s/\?.*//;
 539     if ($locale and $locale ne 'english' and -e "$docdir/locale/$locale/$doc") {
 540       $doc = "$docdir/locale/$locale/$doc";
 541     } else {
 542       $doc = "$docdir/$doc";
 543     }
 544   }
 545
 546   # CGI or document request?
 547   if ($cgi =~ s:^/+::) {
 548     $cgi =~ s:/.*::;
 549     unless ($cgi) {
 550       my $login = "$FEXHOME/cgi-bin/login";
 551       if (-x $login) {
 552         $cgi = untaint(readlink($login) || $login);
 553         $cgi =~ s:.*/::;
 554       }
 555     }
 556
 557     $ENV{SCRIPT_NAME} = $cgi;
 558
 559     # locale CGIs? (vhost comes already with own FEXLIB)
 560     if ($locale and $locale ne 'english'
 561         and -f "$FEXHOME/locale/$locale/cgi-bin/$cgi") {
 562       $ENV{SCRIPT_FILENAME} = $cgi = "$FEXHOME/locale/$locale/cgi-bin/$cgi";
 563       $ENV{FEXLIB} = $FEXLIB = "$FEXHOME/locale/$locale/lib" unless $vhost;
 564     } else {
 565       $ENV{SCRIPT_FILENAME} = $cgi = "$FEXHOME/cgi-bin/$cgi";
 566       $ENV{FEXLIB} = $FEXLIB = "$FEXHOME/lib" unless $vhost;
 567     }
 568
 569     $status = '';
 570     if (-x $cgi and -f $cgi) {
 571       if (@forbidden_hosts and ipin($ra,@forbidden_hosts)) {
 572         fexlog($connect,@log,"FORBIDDEN");
 573         http_error(403);
 574       }
 575       unlink "$spooldir/.error/$ra";
 576       # push @log,"DEBUG: locale=$locale locales=(@locales)";
 577       fexlog($connect,@log,"EXEC $cgi");
 578       eval { local $^W = 0; exec $cgi };
 579       $status = "$! or bad interpreter";
 580       fexlog($connect,@log,"FAILED to exec $cgi : $status");
 581       http_error(555);
 582     } else {
 583       if (-f "$doc/.htindex") {
 584         require "$FEXLIB/dop";
 585         fexlog($connect,@log);
 586
 587         showindex($doc);
 588         STDOUT->flush;
 589         next REQUEST if $keep_alive;
 590         exit;
 591       }
 592       if (-f "$doc/index.html") {
 593         # force redirect if trailing / is missing
 594         # this is mandatory for processing further HTTP request!
 595         if ($doc !~ m{/$}) {
 596           nvt_print(
 597             "HTTP/1.1 301 Moved Permanently",
 598             "Location: $ENV{REQUEST_URL}/",
 599             "Content-Length: 0",
 600             ""
 601           );
 602           fexlog($connect,@log);
 603           next REQUEST if $keep_alive;
 604           exit;
 605         }
 606         $doc .= '/index.html';
 607         $doc =~ s:/+:/:g;
 608       }
 609       $doc =~ s/#.*//; # ignore HTML anchors (stupid msnbot)
 610
 611       # special request for F*EX UNIX clients
 612       if ($ENV{SCRIPT_NAME} eq 'xx.tar') {
 613         bintar(qw'fexget fexsend xx zz ezz');
 614       }
 615       if ($ENV{SCRIPT_NAME} eq 'sex.tar') {
 616         bintar(qw'sexsend sexget sexxx');
 617       }
 618       if ($ENV{SCRIPT_NAME} eq 'afex.tar') {
 619         bintar(qw'afex asex fexget fexsend sexsend sexget');
 620       }
 621       if ($ENV{SCRIPT_NAME} eq 'afs.tar') {
 622         bintar(qw'afex asex fexget fexsend xx sexsend sexget sexxx zz ezz');
 623       }
 624       # URL ends with ".html!" or ".html?!"
 625       if ($doc =~ s/(\.html)!$/$1/ or
 626           $doc =~ /\.html$/ and $ENV{'QUERY_STRING'} eq '!')
 627       { $htmlsource = $doc } else { $htmlsource = '' }
 628
 629       if (-f $doc
 630           or $doc =~ /(.+)\.(tar|tgz|zip)$/ and lstat("$1.stream")
 631           or $doc =~ /(.+)\.tgz$/           and -f "$1.tar"
 632           or $doc =~ /(.+)\.gz$/            and -f $1)
 633       {
 634         unlink "$spooldir/.error/$ra";
 635         delete $ENV{SCRIPT_FILENAME};
 636         $ENV{DOCUMENT_FILENAME} = $doc;
 637         require "$FEXLIB/dop";
 638         fexlog($connect,@log);
 639         dop($doc);
 640         STDOUT->flush;
 641         next REQUEST if $keep_alive;
 642         exit;
 643       } elsif ($uri eq '/bunny') {
 644         fexlog($connect,@log);
 645         nvt_print(
 646           'HTTP/1.1 200 OK',
 647           'Server: fexsrv',
 648           "Content-Type: text/plain",
 649           '',
 650           '=:3',
 651         );
 652         exit;
 653       } elsif ($uri eq '/camel') {
 654         fexlog($connect,@log);
 655         nvt_print(
 656           'HTTP/1.1 200 OK',
 657           'Server: fexsrv',
 658           "Content-Type: text/plain",
 659           '',
 660         );
 661         local $/;
 662         print unpack('u',<DATA>);
 663         exit;
 664       } elsif (-e $cgi) {
 665         $status = 'not executable';
 666       }
 667
 668     }
 669
 670   }
 671
 672   # neither document nor CGI ==> error
 673
 674   if ($status) {
 675     fexlog($connect,@log,"FAILED to exec $cgi : $status");
 676     http_error(666);
 677   } else {
 678     fexlog($connect,@log,"UNKNOWN URL");
 679     badlog($request);
 680     http_error(404);
 681   }
 682   exit;
 683 }
 684
 685
 686 # read one text line unbuffered from STDIN
 687 sub getaline {
 688   my $line = '';
 689   my $n = 0;
 690   my $c;
 691
 692   alarm($timeout);
 693
 694   # must use sysread to avoid perl line buffering
 695   # (later exec would destroy line buffer)
 696   while (sysread STDIN,$c,1) {
 697     $line .= $c;
 698     $n++;
 699     last if $c eq "\n";
 700     if ($n > $bs) {
 701       fexlog($connect,@log,$line,"OVERRUN");
 702       http_error(413);
 703     }
 704   }
 705
 706   alarm(0);
 707
 708   return $line;
 709 }
 710
 711
 712 sub fexlog {
 713   my @log = @_;
 714
 715   foreach my $logdir (@logdir) {
 716     if (open $log,'>>',"$logdir/$log") {
 717       flock $log,LOCK_EX;
 718       seek $log,0,SEEK_END;
 719       print {$log} "\n",join("\n",@log),"\n";
 720       close $log;
 721     } else {
 722       http_die("$0: cannot write to $logdir/$log - $!\n");
 723     }
 724   }
 725 }
 726
 727
 728 sub badchar {
 729   my $bc = shift;
 730
 731   fexlog($connect,@log,"DISCONNECT: bad characters in URL");
 732   debuglog("DISCONNECT: bad characters in URL $uri");
 733   badlog($request);
 734   http_die("\"$bc\" is not allowed in URL");
 735 }
 736
 737
 738 sub bintar {
 739   my $tmpdir = "$FEXHOME/tmp";
 740   my $fs = "$ENV{PROTO}://$ENV{HTTP_HOST}";
 741
 742   if (chdir "$FEXHOME/bin") {
 743     fexlog($connect,@log);
 744     chdir $fstb if $fstb;
 745     mkdir $tmpdir;
 746     foreach my $f (@_) {
 747       copy($f,"$tmpdir/$f","s#fexserver = ''#fexserver = '$fs'#");
 748       chmod 0755,"$tmpdir/$f";
 749     }
 750     chdir $tmpdir or http_die("internal error: $tmpdir - $!");
 751     my $tar = `tar cf - @_ 2>/dev/null`;
 752     unlink @_;
 753     nvt_print(
 754       'HTTP/1.1 200 OK',
 755       'Server: fexsrv',
 756       "Content-Length: ".length($tar),
 757       "Content-Type: application/x-tar",
 758       '',
 759     );
 760     print $tar;
 761     exit;
 762   }
 763 }
 764
 765
 766 sub http_error {
 767   my $error = shift;
 768   my $URL = $ENV{REQUEST_URL}||'';
 769   my $URI = $ENV{REQUEST_URI}||'';
 770
 771   if ($error eq 400) {
 772     http_error_header("400 Bad Request");
 773     nvt_print("Your request $URL is not acceptable.");
 774   } elsif ($error eq 403) {
 775     http_error_header("403 Forbidden");
 776     nvt_print("You have no permission to request $URL");
 777   } elsif ($error eq 404) {
 778     http_error_header("404 Not Found");
 779     nvt_print("The requested URI $URI was not found on this server.");
 780   } elsif ($error eq 413) {
 781     http_error_header("413 Payload Too Large");
 782     nvt_print("Your HTTP header is too large.");
 783   } elsif ($error eq 416) {
 784     http_error_header("416 Requested Range Not Satisfiable");
 785   } elsif ($error eq 503) {
 786     http_error_header("503 Service Unavailable");
 787     # nvt_print("No Perl ipv6 support on this server.");
 788   } else {
 789     http_error_header("555 Unknown Error");
 790     nvt_print("The requested URL $URL produced an internal error.");
 791   }
 792   nvt_print(
 793     "<hr>",
 794     "<address>fexsrv at <a href=\"/index.html\">$hostname:$port</a></address>",
 795     "</body></html>",
 796   );
 797   exit;
 798 }
 799
 800
 801 sub disconnect {
 802   my $info = shift;
 803   my $error = shift;
 804   my $wait = shift||0;
 805
 806   # &$header_hook($connect,$_,$ra) while ($header_hook and $_ = shift @header);
 807   fexlog($connect,@log,"DISCONNECT: $info");
 808   debuglog("DISCONNECT: $info");
 809   errorlog("$ENV{REQUEST_URI} ==> $error");
 810   badlog("$ENV{REQUEST_URI} ==> $error ($info)");
 811
 812   sleep $wait;
 813   nvt_print("HTTP/1.0 $error");
 814   exit;
 815 }
 816
 817
 818 sub http_error_header {
 819   my $error = shift;
 820   my $uri = $ENV{REQUEST_URI};
 821
 822   errorlog("$uri ==> $error") if $uri;
 823   nvt_print(
 824     "HTTP/1.1 $error",
 825     "Connection: close",
 826     "Content-Type: text/html; charset=iso-8859-1",
 827     "",
 828     '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">',
 829     "<html>",
 830     "<head><title>$error</title></head>",
 831     "<body>",
 832     "<h1>$error</h1>",
 833   );
 834 }
 835
 836
 837 sub redirect {
 838   my $uri = shift;
 839   my $r = shift;
 840   my $rr = $redirect{$r};
 841   my $newurl;
 842
 843   $uri =~ s/\Q$r//;
 844
 845   if ($rr =~ s/^!//) {
 846     $newurl = $rr.$uri;
 847       nvt_print(
 848         "HTTP/1.1 301 Moved Permanently",
 849         "Location: $newurl",
 850         "Content-Length: 0",
 851         ""
 852       );
 853   } else {
 854     if ($rr =~ /^http/) {
 855       $newurl = $rr.$uri;
 856     } else {
 857       $newurl = "$ENV{PROTO}://$ENV{HTTP_HOST}$rr$uri";
 858     }
 859
 860     http_header("200 OK");
 861     print html_header("$hostname page has moved");
 862     pq(qq(
 863       '<h3>Please use new URL: <a href="$newurl">$newurl</a></h3>'
 864       '</body></html>'
 865     ));
 866   }
 867   if ($rr =~ /^http/) {
 868     exit;
 869   } else {
 870     &reexec;
 871   }
 872 }
 873
 874
 875 sub badlog {
 876   my $request = shift;
 877   my @n;
 878   my $ed = "$spooldir/.error";
 879   local $_;
 880
 881   if (@ignore_error) {
 882     foreach (@ignore_error) {
 883       return if $request =~ /$_/;
 884     }
 885   }
 886
 887   if ($ra and $max_error and $max_error_handler) {
 888     mkdir($ed) unless -d $ed;
 889
 890     if (open $ra,"+>>$ed/$ra") {
 891       flock($ra,LOCK_EX);
 892       seek $ra,0,SEEK_SET;
 893       @n = <$ra>;
 894       printf {$ra} "%s %s\n",isodate(time),$request;
 895       close $ra;
 896       &$max_error_handler($ra,@n) if scalar(@n) > $max_error;
 897     }
 898   }
 899 }
 900
 901
 902 __END__
 903 M("`@("`@("`@("`@("`@("`@("`@("`@("`@("`@("`@("PM)R(G+5P*("`@
 904 M("`@("`@("`@("`@("`@("`@("`@("]@8&`M+B`@(&!<("`@("Q=+B`@("`@
 905 M("`@("`@("`@("`@("`@("`L+BY?"B`@("`@("`@("`@("`@("`@("`@("`@
 906 M+&`@("`@(&`B+B`@72X@("`@(&`N("`@("`@("`@("`@("`@7U]?+BY>(&!?
 907 M)V`B(B(*("`@("`@("`@("`@("`@("`@("`@("`I("`@("`@("`G+"TG+2T@
 908 M+B`@("!@+B`@("`@(%]?7RPN+2<@("XN("T@("`G("TP("Y?"B`@("`@("`@
 909 M("`@+"X@("`@("`@("`@?%]?+"Y?("!?("`N+5\@("!<("`\("Y@(B<G)V`L
 910 M7R`@("`@("`@+2!?("TN("`@("`@("<M+BX*("`@("`@("`@('P@(&8M+2TM
 911 M+2TM+2<O("`@("!@)RTM+BXL("`@("`M("`@("`@("`@("T@("`@("`@("`@
 912 M("`@("`G("XL7U\N7%\N)PH@("`@("`@("`@8"TM)R<G)R<G8"TM7"`@("`@
 913 M("`@("`@("!@)RTM+B`@("`@("`@("`@("`@("`@("`@7RPN)RTM)R<*("`@
 914 M("`@("`@("`@("`@("`@("`@("\@("`@("`@("`@("`@("`@("!@8#T@+2`@
 915 M+2`@("!?+2`@7RXM)PH@("`@("`@("`@("`@("`@("`@("!\("`@("`@("`@
 916 M("`@("`@("`@("`@("!?)V`@("`G)U\M+2<*("`@("`@("`@("`@("`@("`@
 917 M("`@?"`@("`@("`@("`@("`@("`@("`O("`@?"T]+BXM+2<*("`@("`@("`@
 918 M("`@("`@(%\@("`@("<N("`@("`@("`N7R`@(%\N+2=@)R`@(&!?7PH@("`@
 919 M("`@("`@("`@("PG("`N("PG("TL3%]?+WP@(%P@8"<G+&\N("`@+5\@("`@
 920 M)V`M+2X*("`@("`@("`@("`@("`@+BPG(BT@("`O("`@("`@("`@?"`@8'8@
 921 M+R`N("PG8"TM+BXG7R`G+@H@("`@("`@("`@("`@("`@("TN+E\L)R`@("`@
 922 M('P@("!\("`@)RTM+E]@("!?+R`@('P@("!\"B`@("`@("`@("`@("`@("`@
 923 M("`@("`@("`@("=@8"<@6R`@("`@("`@("=@)R`@("`L+RXN+PH@("`@("`@
 924 M("`@("`@("`@("`@("`@("`@('P@("`M+B<@("`@("`@("`@("`@("Y;("`@
 925 M+PH@("`@("`@("`@("`@("`@("`@(%]?7U]?7RX@("`L.E]?7U]?7U]?7U]?
 926 M7U]?7RQ@("PG"B`@("TM+2TM+2TM+2TM+2TM+2TM+2TM+2TM+2T@+2(M+2TM
 927 M+2TM+2TM+2TM+2TM+2T]+0H@+2TM+2TM+2TM+2TM+2TM+2TM+2TM+2TM+2TM
 928 6+2TM+2TM+2TM+2TM+2TM+2TM+2TM"@``