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