bin/fexsrv

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