Original release 20160104

[fex.git] / bin / fexsrv

diff --git a/bin/fexsrv b/bin/fexsrv
index 11911ffcb893fabbe2f293daa3de26601e272735..e89b6f9bd578d62186219d255d076dd2c37ceb9d 100755 (executable)
--- a/bin/fexsrv
+++ b/bin/fexsrv
@@ -11,7 +11,7 @@ use IO::Handle;
 use Fcntl qw':flock :seek';
 use warnings;
 
 use Fcntl qw':flock :seek';
 use warnings;
 

-BEGIN { 
+BEGIN {

   # stunnel workaround
   $SIG{CHLD} = "DEFAULT";
   $ENV{PERLINIT} = q{
   # stunnel workaround
   $SIG{CHLD} = "DEFAULT";
   $ENV{PERLINIT} = q{


@@ -63,7 +63,7 @@ if (@ARGV and $ARGV[0] eq 'stunnel' and $ENV{REMOTE_HOST} =~ /(.+)/) {
 }
 
 # KEEP_ALIVE <== callback from CGI
 }
 
 # KEEP_ALIVE <== callback from CGI

-if ($ENV{KEEP_ALIVE}) { 
+if ($ENV{KEEP_ALIVE}) {

   $keep_alive = $ENV{KEEP_ALIVE};
 } else {
   %ENV = ( PERLINIT => $ENV{PERLINIT} );   # clean environment
   $keep_alive = $ENV{KEEP_ALIVE};
 } else {
   %ENV = ( PERLINIT => $ENV{PERLINIT} );   # clean environment


@@ -91,7 +91,7 @@ foreach my $lib (
 
 # import from fex.pp
 our ($hostname,$debug,$timeout,$max_error,$max_error_handler);
 
 # import from fex.pp
 our ($hostname,$debug,$timeout,$max_error,$max_error_handler);

-our ($spooldir,@logdir,$docdir,$xkeydir,$lockdir);
+our ($spooldir,@logdir,$docdir,$xkeydir,$akeydir,$lockdir);

 our ($force_https,$default_locale,$bs,$MB,$adlm);
 our (@locales);
 
 our ($force_https,$default_locale,$bs,$MB,$adlm);
 our (@locales);
 


@@ -107,7 +107,7 @@ our $hid = ''; # header ID
 our @log;
 
 $0 = untaint($0);
 our @log;
 
 $0 = untaint($0);

-  
+

 $ENV{GATEWAY_INTERFACE} = 'CGI/1.1f';
 $ENV{SERVER_NAME} = $hostname;
 $ENV{REQUEST_METHOD} = '';
 $ENV{GATEWAY_INTERFACE} = 'CGI/1.1f';
 $ENV{SERVER_NAME} = $hostname;
 $ENV{REQUEST_METHOD} = '';


@@ -134,12 +134,12 @@ if ($keep_alive) {
   }
   $ra = $ENV{REMOTE_ADDR};
   $rh = $ENV{REMOTE_HOST};
   }
   $ra = $ENV{REMOTE_ADDR};
   $rh = $ENV{REMOTE_HOST};

-} 
+}

 
 # new session
 else {
   my $iaddr;
 
 # new session
 else {
   my $iaddr;

-  
+

   # HTTPS connect
   if ($ssl_ra) {
     $ENV{PROTO} = 'https';
   # HTTPS connect
   if ($ssl_ra) {
     $ENV{PROTO} = 'https';


@@ -156,7 +156,7 @@ else {
     $rh ||= '-';
     $port = 443;
     # print {$log} "X-SSL-Remote-Host: $ssl_ra\n";
     $rh ||= '-';
     $port = 443;
     # print {$log} "X-SSL-Remote-Host: $ssl_ra\n";

-  } 
+  }

 
   # HTTP connect
   else {
 
   # HTTP connect
   else {


@@ -182,7 +182,7 @@ else {
 
   $ENV{REMOTE_HOST} = $rh || '';
 
 
   $ENV{REMOTE_HOST} = $rh || '';
 

-  $ENV{HTTP_HOST} = ($port == 80 or $port == 443) 
+  $ENV{HTTP_HOST} = ($port == 80 or $port == 443)

                   ? $hostname : "$hostname:$port";
 
   $ENV{PORT} = $port;
                   ? $hostname : "$hostname:$port";
 
   $ENV{PORT} = $port;


@@ -213,7 +213,7 @@ REQUEST: while (*STDIN) {
 
   if (defined $ENV{REQUESTCOUNT}) { $ENV{REQUESTCOUNT}++ }
   else                            { $ENV{REQUESTCOUNT} = 0 }
 
   if (defined $ENV{REQUESTCOUNT}) { $ENV{REQUESTCOUNT}++ }
   else                            { $ENV{REQUESTCOUNT} = 0 }

-  
+

   $connect = sprintf "%s:%s %s %s %s [%s_%s]",
                      $keep_alive ? 'CONTINUE' : 'CONNECT',
                      $port,
   $connect = sprintf "%s:%s %s %s %s [%s_%s]",
                      $keep_alive ? 'CONTINUE' : 'CONNECT',
                      $port,


@@ -246,16 +246,17 @@ REQUEST: while (*STDIN) {
       fexlog($connect,@log,"OVERRUN");
       http_error(413);
     }
       fexlog($connect,@log,"OVERRUN");
       http_error(413);
     }

-    
-    if (/^(GET \/|X-Forwarded-For|User-Agent)/i) {
+
+    if (/^(GET \/|\S*Forwarded|\S*Client-IP|\S*Coming-From|User-Agent)/i) {

       $hid .= $_."\n";
     }
 
     # reverse-proxy?
       $hid .= $_."\n";
     }
 
     # reverse-proxy?

+    # (only IPv4 support!)

     if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra and
     if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra and

-       /^X-Forwarded-For: ([\d.]+)/
+       /^\S*(Forwarded|Client-IP|Coming-From)\S*: ([\d.]+)/i

     ) {
     ) {

-      $ENV{REMOTE_ADDR} = $ra = $1;
+      $ENV{REMOTE_ADDR} = $ra = $2;

       $ENV{REMOTE_HOST} = $rh = gethostbyaddr(inet_aton($ra),AF_INET) || '';
       $ENV{HTTP_HOST} = $hostname;
       if ($ENV{PROTO} eq 'https') { $port = 443 }
       $ENV{REMOTE_HOST} = $rh = gethostbyaddr(inet_aton($ra),AF_INET) || '';
       $ENV{HTTP_HOST} = $hostname;
       if ($ENV{PROTO} eq 'https') { $port = 443 }


@@ -265,11 +266,11 @@ REQUEST: while (*STDIN) {
 
   exit unless @header;
   exit if $header =~ /^\s*$/;
 
   exit unless @header;
   exit if $header =~ /^\s*$/;

-  
+

   $ENV{HTTP_HEADER} = $header;
   debuglog($header);
   # http_die("<pre>$header</pre>");
   $ENV{HTTP_HEADER} = $header;
   debuglog($header);
   # http_die("<pre>$header</pre>");

-  
+

   $ENV{'HTTP_HEADER_LENGTH'} = $hl;
   $ENV{REQUEST_URI} = $uri = '';
   $cgi = '';
   $ENV{'HTTP_HEADER_LENGTH'} = $hl;
   $ENV{REQUEST_URI} = $uri = '';
   $cgi = '';


@@ -281,7 +282,7 @@ REQUEST: while (*STDIN) {
     badlog("no HTTP request: $request");
     exit;
   }
     badlog("no HTTP request: $request");
     exit;
   }

-  
+

   if ($force_https and $port != 443
       and $request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
     $request = $2;
   if ($force_https and $port != 443
       and $request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
     $request = $2;


@@ -312,7 +313,7 @@ REQUEST: while (*STDIN) {
     }
   }
 
     }
   }
 

-  if ($request =~ /^OPTIONS FEX HTTP\/[\d\.]+$/i) {
+  if ($request =~ /^OPTIONS \/?FEX HTTP\/[\d\.]+$/i) {

     fexlog($connect,@log);
     nvt_print(
       "HTTP/1.1 201 OK",
     fexlog($connect,@log);
     nvt_print(
       "HTTP/1.1 201 OK",


@@ -368,7 +369,7 @@ REQUEST: while (*STDIN) {
   }
 
   while ($_ = shift @header) {
   }
 
   while ($_ = shift @header) {

-    
+

     # header inquisition!
     &$header_hook($connect,$_,$ra) if $header_hook;
 
     # header inquisition!
     &$header_hook($connect,$_,$ra) if $header_hook;
 


@@ -383,11 +384,11 @@ REQUEST: while (*STDIN) {
     if ($header =~ /\nRange:/ and /^User-Agent: (FDM)/) {
       disconnect($1,"499 Download Manager $1 Not Supported",30);
     }
     if ($header =~ /\nRange:/ and /^User-Agent: (FDM)/) {
       disconnect($1,"499 Download Manager $1 Not Supported",30);
     }

-    
+

     if (/^User-Agent: (Java\/[\d\.]+)/) {
       disconnect($1,"499 User-Agent $1 Not Supported",30);
     }
     if (/^User-Agent: (Java\/[\d\.]+)/) {
       disconnect($1,"499 User-Agent $1 Not Supported",30);
     }

-    
+

     if (/^Range:.*,/) {
       disconnect("Range a,b","416 Requested Range Not Satisfiable",30);
     }
     if (/^Range:.*,/) {
       disconnect("Range a,b","416 Requested Range Not Satisfiable",30);
     }


@@ -460,7 +461,7 @@ REQUEST: while (*STDIN) {
   &$header_hook($connect,$header,$ra) if $header_hook;
 
   exit unless $cgi;
   &$header_hook($connect,$header,$ra) if $header_hook;
 
   exit unless $cgi;

-  
+

   # extra download request? (request http://fexserver//xkey)
   if ($cgi =~ m{^//([^/]+)$}) {
     my $xkey = $1;
   # extra download request? (request http://fexserver//xkey)
   if ($cgi =~ m{^//([^/]+)$}) {
     my $xkey = $1;


@@ -492,13 +493,29 @@ REQUEST: while (*STDIN) {
 
   # get locale
   if (($ENV{QUERY_STRING} =~ /.*locale=([\w-]+)/ or
 
   # get locale
   if (($ENV{QUERY_STRING} =~ /.*locale=([\w-]+)/ or

-       $ENV{HTTP_COOKIE}  =~ /.*locale=([\w-]+)/) 
+       $ENV{HTTP_COOKIE}  =~ /.*locale=([\w-]+)/)

       and -d "$FEXHOME/locale/$1") {
     $ENV{LOCALE} = $locale = $1;
   } else {
     $ENV{LOCALE} = $locale = $default_locale;
   }
 
       and -d "$FEXHOME/locale/$1") {
     $ENV{LOCALE} = $locale = $1;
   } else {
     $ENV{LOCALE} = $locale = $default_locale;
   }
 

+  # for dynamic HTML documents
+  if ($ENV{HTTP_COOKIE} =~ /akey=(\w+)/) {
+    my $akey = $1;
+    my ($user,$id);
+    if ($user = readlink "$akeydir/$akey") {
+      $user =~ s:.*/::;
+      $user = untaint($user);
+      if ($id = slurp("$spooldir/$user/@")) {
+        chomp $id;
+        $ENV{AKEY} = $akey;
+        $ENV{USER} = $user;
+        $ENV{ID}   = $id;
+      }
+    }
+  }
+

   # check for name based virtual host
   $vhost = vhost($ENV{'HTTP_HOST'});
 
   # check for name based virtual host
   $vhost = vhost($ENV{'HTTP_HOST'});
 


@@ -520,7 +537,7 @@ REQUEST: while (*STDIN) {
       $locale = $default_locale;
     }
   }
       $locale = $default_locale;
     }
   }

-              
+

   # prepare document file name
   if ($ENV{REQUEST_METHOD} =~ /^GET|HEAD$/) {
     if (%redirect) {
   # prepare document file name
   if ($ENV{REQUEST_METHOD} =~ /^GET|HEAD$/) {
     if (%redirect) {


@@ -622,17 +639,17 @@ REQUEST: while (*STDIN) {
         bintar(qw'afex asex fexget fexsend xx sexsend sexget sexxx zz ezz');
       }
       # URL ends with ".html!" or ".html?!"
         bintar(qw'afex asex fexget fexsend xx sexsend sexget sexxx zz ezz');
       }
       # URL ends with ".html!" or ".html?!"

-      if ($doc =~ s/(\.html)!$/$1/ or 
-          $doc =~ /\.html$/ and $ENV{'QUERY_STRING'} eq '!') 
+      if ($doc =~ s/(\.html)!$/$1/ or
+          $doc =~ /\.html$/ and $ENV{'QUERY_STRING'} eq '!')

       { $htmlsource = $doc } else { $htmlsource = '' }
 
       { $htmlsource = $doc } else { $htmlsource = '' }
 

-      if (-f $doc 
+      if (-f $doc

           or $doc =~ /(.+)\.(tar|tgz|zip)$/ and lstat("$1.stream")
           or $doc =~ /(.+)\.tgz$/           and -f "$1.tar"
           or $doc =~ /(.+)\.gz$/            and -f $1)
       {
         unlink "$spooldir/.error/$ra";
           or $doc =~ /(.+)\.(tar|tgz|zip)$/ and lstat("$1.stream")
           or $doc =~ /(.+)\.tgz$/           and -f "$1.tar"
           or $doc =~ /(.+)\.gz$/            and -f $1)
       {
         unlink "$spooldir/.error/$ra";

-        delete $ENV{SCRIPT_FILENAME};        
+        delete $ENV{SCRIPT_FILENAME};

         $ENV{DOCUMENT_FILENAME} = $doc;
         require "$FEXLIB/dop";
         fexlog($connect,@log);
         $ENV{DOCUMENT_FILENAME} = $doc;
         require "$FEXLIB/dop";
         fexlog($connect,@log);


@@ -670,7 +687,7 @@ REQUEST: while (*STDIN) {
   }
 
   # neither document nor CGI ==> error
   }
 
   # neither document nor CGI ==> error

-  
+

   if ($status) {
     fexlog($connect,@log,"FAILED to exec $cgi : $status");
     http_error(666);
   if ($status) {
     fexlog($connect,@log,"FAILED to exec $cgi : $status");
     http_error(666);


@@ -711,7 +728,7 @@ sub getaline {
 
 sub fexlog {
   my @log = @_;
 
 sub fexlog {
   my @log = @_;

-  
+

   foreach my $logdir (@logdir) {
     if (open $log,'>>',"$logdir/$log") {
       flock $log,LOCK_EX;
   foreach my $logdir (@logdir) {
     if (open $log,'>>',"$logdir/$log") {
       flock $log,LOCK_EX;


@@ -727,7 +744,7 @@ sub fexlog {
 
 sub badchar {
   my $bc = shift;
 
 sub badchar {
   my $bc = shift;

-  
+

   fexlog($connect,@log,"DISCONNECT: bad characters in URL");
   debuglog("DISCONNECT: bad characters in URL $uri");
   badlog($request);
   fexlog($connect,@log,"DISCONNECT: bad characters in URL");
   debuglog("DISCONNECT: bad characters in URL $uri");
   badlog($request);


@@ -738,7 +755,7 @@ sub badchar {
 sub bintar {
   my $tmpdir = "$FEXHOME/tmp";
   my $fs = "$ENV{PROTO}://$ENV{HTTP_HOST}";
 sub bintar {
   my $tmpdir = "$FEXHOME/tmp";
   my $fs = "$ENV{PROTO}://$ENV{HTTP_HOST}";

-  
+

   if (chdir "$FEXHOME/bin") {
     fexlog($connect,@log);
     chdir $fstb if $fstb;
   if (chdir "$FEXHOME/bin") {
     fexlog($connect,@log);
     chdir $fstb if $fstb;


@@ -802,7 +819,7 @@ sub disconnect {
   my $info = shift;
   my $error = shift;
   my $wait = shift||0;
   my $info = shift;
   my $error = shift;
   my $wait = shift||0;

-  
+

   # &$header_hook($connect,$_,$ra) while ($header_hook and $_ = shift @header);
   fexlog($connect,@log,"DISCONNECT: $info");
   debuglog("DISCONNECT: $info");
   # &$header_hook($connect,$_,$ra) while ($header_hook and $_ = shift @header);
   fexlog($connect,@log,"DISCONNECT: $info");
   debuglog("DISCONNECT: $info");


@@ -818,7 +835,7 @@ sub disconnect {
 sub http_error_header {
   my $error = shift;
   my $uri = $ENV{REQUEST_URI};
 sub http_error_header {
   my $error = shift;
   my $uri = $ENV{REQUEST_URI};

-  
+

   errorlog("$uri ==> $error") if $uri;
   nvt_print(
     "HTTP/1.1 $error",
   errorlog("$uri ==> $error") if $uri;
   nvt_print(
     "HTTP/1.1 $error",


@@ -839,24 +856,24 @@ sub redirect {
   my $r = shift;
   my $rr = $redirect{$r};
   my $newurl;
   my $r = shift;
   my $rr = $redirect{$r};
   my $newurl;

-  
+

   $uri =~ s/\Q$r//;
 
   if ($rr =~ s/^!//) {
     $newurl = $rr.$uri;
   $uri =~ s/\Q$r//;
 
   if ($rr =~ s/^!//) {
     $newurl = $rr.$uri;

-      nvt_print(
-        "HTTP/1.1 301 Moved Permanently",
-        "Location: $newurl",
-        "Content-Length: 0",
-        ""
-      );
+    nvt_print(
+      "HTTP/1.1 301 Moved Permanently",
+      "Location: $newurl",
+      "Content-Length: 0",
+      ""
+    );

   } else {
     if ($rr =~ /^http/) {
       $newurl = $rr.$uri;
     } else {
       $newurl = "$ENV{PROTO}://$ENV{HTTP_HOST}$rr$uri";
     }
   } else {
     if ($rr =~ /^http/) {
       $newurl = $rr.$uri;
     } else {
       $newurl = "$ENV{PROTO}://$ENV{HTTP_HOST}$rr$uri";
     }

-  
+

     http_header("200 OK");
     print html_header("$hostname page has moved");
     pq(qq(
     http_header("200 OK");
     print html_header("$hostname page has moved");
     pq(qq(


@@ -877,13 +894,13 @@ sub badlog {
   my @n;
   my $ed = "$spooldir/.error";
   local $_;
   my @n;
   my $ed = "$spooldir/.error";
   local $_;

-  
+

   if (@ignore_error) {
     foreach (@ignore_error) {
       return if $request =~ /$_/;
     }
   }
   if (@ignore_error) {
     foreach (@ignore_error) {
       return if $request =~ /$_/;
     }
   }

-  
+

   if ($ra and $max_error and $max_error_handler) {
     mkdir($ed) unless -d $ed;
 
   if ($ra and $max_error and $max_error_handler) {
     mkdir($ed) unless -d $ed;