]> git.treefish.org Git - fex.git/blob - bin/fexsrv
8bef7fc65fb91fa7dd7018f7f97a7fec586127f7
[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,$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"@``