]> git.treefish.org Git - fex.git/blob - bin/fexsrv
6a3e80e73641aa0c91eaf2e2d66bd127177fb6f6
[fex.git] / 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"@``