]> git.treefish.org Git - fex.git/blobdiff - bin/fexsrv
projects / fex.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Original release 20150729
[fex.git] / bin / fexsrv
diff --git a/bin/fexsrv b/bin/fexsrv
index 27e331864289d4d0674044a17fd996b54a2d5b8a..11911ffcb893fabbe2f293daa3de26601e272735 100755 (executable)
--- a/bin/fexsrv
+++ b/bin/fexsrv
@@ -1,4 +1,4 @@
-#!/usr/bin/perl -wT
+#!/usr/bin/perl -T
 
 # fexsrv : web server for F*EX service
 #
 
 # fexsrv : web server for F*EX service
 #
@@ -9,9 +9,50 @@ use 5.008;
 use Socket;
 use IO::Handle;
 use Fcntl qw':flock :seek';
 use Socket;
 use IO::Handle;
 use Fcntl qw':flock :seek';
-
-# stunnel workaround
-BEGIN { $SIG{CHLD} = "DEFAULT" }
+use warnings;
+
+BEGIN { 
+  # stunnel workaround
+  $SIG{CHLD} = "DEFAULT";
+  $ENV{PERLINIT} = q{
+    unshift @INC,(getpwuid($<))[7].'/perl';
+    # web error handler
+    $SIG{__DIE__} = $SIG{__WARN__} = sub {
+      my $info = '';
+      my $url = $ENV{REQUEST_URL}||'';
+      my @d = localtime time;
+      my $time = sprintf('%d-%02d-%02d %02d:%02d:%02d',
+                 $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]);
+      if ($admin) {
+        my $mailto = "mailto:$admin?subject=fex%20bug";
+        $info = "<h3>send this error to <a href=\"$mailto\">$admin</a></h3>";
+      }
+      $_ = join("\n",@_);
+      chomp;
+      s/&/&amp;/g;
+      s/</&lt;/g;
+      $_ = join("\n",
+        "<html><body>",
+        "<h1>INTERNAL ERROR in $0</h1>",
+        "<pre>\n$_\n</pre>\n<p>",
+        "$url\n<p>",
+        "$time\n<p>",
+        "$info\n<p>",
+        "</body></html>"
+      );
+      $length = length;
+      unless ($HTTP_HEADER) {
+        print "HTTP/1.0 200 ERROR\r\n";
+        print "Content-Type: text/html\r\n";
+        print "Content-Length: $length\r\n";
+        print "\r\n";
+      }
+      print;
+      exit 99;
+    }
+  };
+  eval $ENV{PERLINIT};
+}
 
 # use BSD::Resource;
 # setrlimit(RLIMIT_CPU,999,999) or die "$0: $!\n";
 
 # use BSD::Resource;
 # setrlimit(RLIMIT_CPU,999,999) or die "$0: $!\n";
@@ -25,10 +66,10 @@ if (@ARGV and $ARGV[0] eq 'stunnel' and $ENV{REMOTE_HOST} =~ /(.+)/) {
 if ($ENV{KEEP_ALIVE}) { 
   $keep_alive = $ENV{KEEP_ALIVE};
 } else {
 if ($ENV{KEEP_ALIVE}) { 
   $keep_alive = $ENV{KEEP_ALIVE};
 } else {
-  %ENV = ();   # clean environment
+  %ENV = ( PERLINIT => $ENV{PERLINIT} );   # clean environment
 }
 
 }
 
-$ENV{HOME} = (getpwuid($<))[7] or die "$0: no HOME\n";
+$ENV{HOME} = (getpwuid($<))[7] or die "no HOME";
 
 # fexsrv MUST be run with full path!
 if ($0 =~ m:^(/.+)/bin/fexsrv:) {
 
 # fexsrv MUST be run with full path!
 if ($0 =~ m:^(/.+)/bin/fexsrv:) {
@@ -50,16 +91,16 @@ 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 ($force_https,$default_locale,$bs,$adlm);
+our ($spooldir,@logdir,$docdir,$xkeydir,$lockdir);
+our ($force_https,$default_locale,$bs,$MB,$adlm);
 our (@locales);
 
 # load common code (local config: $FEXHOME/lib/fex.ph)
 our (@locales);
 
 # load common code (local config: $FEXHOME/lib/fex.ph)
-require "$FEXLIB/fex.pp" or die "$0: cannot load $FEXLIB/fex.pp - $!\n";
+require "$FEXLIB/fex.pp" or die "cannot load $FEXLIB/fex.pp - $!\n";
 
 chdir $spooldir or http_die("$0: $spooldir - $!\n");
 
 
 chdir $spooldir or http_die("$0: $spooldir - $!\n");
 
-our $log = "$logdir/fexsrv.log";
+our $log = 'fexsrv.log';
 our $error = 'F*EX ERROR';
 our $htmlsource;
 our $hid = ''; # header ID
 our $error = 'F*EX ERROR';
 our $htmlsource;
 our $hid = ''; # header ID
@@ -67,8 +108,9 @@ our @log;
 
 $0 = untaint($0);
   
 
 $0 = untaint($0);
   
-$ENV{GATEWAY_INTERFACE} = 'CGI/1.1';
+$ENV{GATEWAY_INTERFACE} = 'CGI/1.1f';
 $ENV{SERVER_NAME} = $hostname;
 $ENV{SERVER_NAME} = $hostname;
+$ENV{REQUEST_METHOD} = '';
 $ENV{QUERY_STRING} = '';
 $ENV{HTTP_COOKIE} = '';
 $ENV{PATH_INFO} = '';
 $ENV{QUERY_STRING} = '';
 $ENV{HTTP_COOKIE} = '';
 $ENV{PATH_INFO} = '';
@@ -119,7 +161,7 @@ else {
   # HTTP connect
   else {
     $ENV{PROTO} = 'http';
   # HTTP connect
   else {
     $ENV{PROTO} = 'http';
-    my $sa = getpeername(STDIN) or die "$0: no network stream on STDIN\n";
+    my $sa = getpeername(STDIN) or die "no network stream on STDIN\n";
     if (sockaddr_family($sa) == AF_INET) {
       ($ENV{REMOTE_PORT},$iaddr) = sockaddr_in($sa);
       $ENV{REMOTE_ADDR} = $ra = inet_ntoa($iaddr);
     if (sockaddr_family($sa) == AF_INET) {
       ($ENV{REMOTE_PORT},$iaddr) = sockaddr_in($sa);
       $ENV{REMOTE_ADDR} = $ra = inet_ntoa($iaddr);
@@ -129,11 +171,11 @@ else {
       $^W = 0; eval 'use Socket6'; $^W = 1;
       http_error(503) if $@;
       ($ENV{REMOTE_PORT},$iaddr) = unpack_sockaddr_in6($sa);
       $^W = 0; eval 'use Socket6'; $^W = 1;
       http_error(503) if $@;
       ($ENV{REMOTE_PORT},$iaddr) = unpack_sockaddr_in6($sa);
-      $ENV{REMOTE_ADDR} = $ra = inet_ntop(AF_INET6, $iaddr);
+      $ENV{REMOTE_ADDR} = $ra = inet_ntop(AF_INET6,$iaddr);
       $rh = gethostbyaddr($iaddr,AF_INET6);
       ($port) = unpack_sockaddr_in6(getsockname(STDIN));
     } else {
       $rh = gethostbyaddr($iaddr,AF_INET6);
       ($port) = unpack_sockaddr_in6(getsockname(STDIN));
     } else {
-      die "$0: unknown IP version\n";
+      die "unknown IP version\n";
     }
     $port = 80 unless $port;
   }
     }
     $port = 80 unless $port;
   }
@@ -143,6 +185,7 @@ else {
   $ENV{HTTP_HOST} = ($port == 80 or $port == 443) 
                   ? $hostname : "$hostname:$port";
 
   $ENV{HTTP_HOST} = ($port == 80 or $port == 443) 
                   ? $hostname : "$hostname:$port";
 
+  $ENV{PORT} = $port;
 }
 
 if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra) {
 }
 
 if ($reverse_proxy_ip and $reverse_proxy_ip eq $ra) {
@@ -199,6 +242,10 @@ REQUEST: while (*STDIN) {
       $header{$1} = $2 if /(.+)\s*:\s*(.+)/;
       push @log,$_;
     }
       $header{$1} = $2 if /(.+)\s*:\s*(.+)/;
       push @log,$_;
     }
+    if ($hl > $MB) {
+      fexlog($connect,@log,"OVERRUN");
+      http_error(413);
+    }
     
     if (/^(GET \/|X-Forwarded-For|User-Agent)/i) {
       $hid .= $_."\n";
     
     if (/^(GET \/|X-Forwarded-For|User-Agent)/i) {
       $hid .= $_."\n";
@@ -306,6 +353,7 @@ REQUEST: while (*STDIN) {
   }
 
   if ($request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
   }
 
   if ($request =~ /^(GET|HEAD|POST)\s+(.+)\s+(HTTP\/[\d\.]+$)/i) {
+    $ENV{REQUEST}       = $_;
     $ENV{REQUEST_METHOD} = uc($1);
     $ENV{REQUEST_URI}    = $uri = $cgi = $2;
     $ENV{HTTP_VERSION}   = $protocol = $3;
     $ENV{REQUEST_METHOD} = uc($1);
     $ENV{REQUEST_URI}    = $uri = $cgi = $2;
     $ENV{HTTP_VERSION}   = $protocol = $3;
@@ -457,7 +505,9 @@ REQUEST: while (*STDIN) {
   if ($debug) {
     debuglog("ENV:\n");
     foreach $var (sort keys %ENV) {
   if ($debug) {
     debuglog("ENV:\n");
     foreach $var (sort keys %ENV) {
-      debuglog(sprintf "  %s = >%s<\n",$var,$ENV{$var});
+      if (defined($ENV{$var})) {
+        debuglog(sprintf "  %s = >%s<\n",$var,$ENV{$var});
+      }
     }
     debuglog("\n");
   }
     }
     debuglog("\n");
   }
@@ -473,12 +523,20 @@ REQUEST: while (*STDIN) {
               
   # prepare document file name
   if ($ENV{REQUEST_METHOD} =~ /^GET|HEAD$/) {
               
   # prepare document file name
   if ($ENV{REQUEST_METHOD} =~ /^GET|HEAD$/) {
+    if (%redirect) {
+      foreach my $r (keys %redirect) {
+        if ($uri =~ /^\Q$r/) {
+          redirect($uri,$r);
+          exit;
+        }
+      }
+    }
     $doc = untaint($uri);
     $doc =~ s/%([\dA-F]{2})/unpack("a",pack("H2",$1))/ge;
     $doc =~ m:/\.\./: and http_error(403);
     $doc =~ s:^/+::;
     $doc =~ s/\?.*//;
     $doc = untaint($uri);
     $doc =~ s/%([\dA-F]{2})/unpack("a",pack("H2",$1))/ge;
     $doc =~ m:/\.\./: and http_error(403);
     $doc =~ s:^/+::;
     $doc =~ s/\?.*//;
-    if ($locale and -e "$docdir/locale/$locale/$doc") {
+    if ($locale and $locale ne 'english' and -e "$docdir/locale/$locale/$doc") {
       $doc = "$docdir/locale/$locale/$doc";
     } else {
       $doc = "$docdir/$doc";
       $doc = "$docdir/locale/$locale/$doc";
     } else {
       $doc = "$docdir/$doc";
@@ -514,7 +572,7 @@ REQUEST: while (*STDIN) {
         fexlog($connect,@log,"FORBIDDEN");
         http_error(403);
       }
         fexlog($connect,@log,"FORBIDDEN");
         http_error(403);
       }
-      unlink "$logdir/.error/$ra";
+      unlink "$spooldir/.error/$ra";
       # push @log,"DEBUG: locale=$locale locales=(@locales)";
       fexlog($connect,@log,"EXEC $cgi");
       eval { local $^W = 0; exec $cgi };
       # push @log,"DEBUG: locale=$locale locales=(@locales)";
       fexlog($connect,@log,"EXEC $cgi");
       eval { local $^W = 0; exec $cgi };
@@ -573,7 +631,7 @@ REQUEST: while (*STDIN) {
           or $doc =~ /(.+)\.tgz$/           and -f "$1.tar"
           or $doc =~ /(.+)\.gz$/            and -f $1)
       {
           or $doc =~ /(.+)\.tgz$/           and -f "$1.tar"
           or $doc =~ /(.+)\.gz$/            and -f $1)
       {
-        unlink "$logdir/.error/$ra";
+        unlink "$spooldir/.error/$ra";
         delete $ENV{SCRIPT_FILENAME};        
         $ENV{DOCUMENT_FILENAME} = $doc;
         require "$FEXLIB/dop";
         delete $ENV{SCRIPT_FILENAME};        
         $ENV{DOCUMENT_FILENAME} = $doc;
         require "$FEXLIB/dop";
@@ -628,6 +686,7 @@ REQUEST: while (*STDIN) {
 # read one text line unbuffered from STDIN
 sub getaline {
   my $line = '';
 # read one text line unbuffered from STDIN
 sub getaline {
   my $line = '';
+  my $n = 0;
   my $c;
 
   alarm($timeout);
   my $c;
 
   alarm($timeout);
@@ -636,7 +695,12 @@ sub getaline {
   # (later exec would destroy line buffer)
   while (sysread STDIN,$c,1) {
     $line .= $c;
   # (later exec would destroy line buffer)
   while (sysread STDIN,$c,1) {
     $line .= $c;
+    $n++;
     last if $c eq "\n";
     last if $c eq "\n";
+    if ($n > $bs) {
+      fexlog($connect,@log,$line,"OVERRUN");
+      http_error(413);
+    }
   }
 
   alarm(0);
   }
 
   alarm(0);
@@ -647,18 +711,20 @@ sub getaline {
 
 sub fexlog {
   my @log = @_;
 
 sub fexlog {
   my @log = @_;
-  if (open $log,">>$log") {
-    flock $log,LOCK_EX;
-    seek $log,0,SEEK_END;
-    print {$log} "\n",join("\n",@log),"\n";
-    close $log;
-  } else {
-    http_die("$0: cannot write to $log - $!\n");
+  
+  foreach my $logdir (@logdir) {
+    if (open $log,'>>',"$logdir/$log") {
+      flock $log,LOCK_EX;
+      seek $log,0,SEEK_END;
+      print {$log} "\n",join("\n",@log),"\n";
+      close $log;
+    } else {
+      http_die("$0: cannot write to $logdir/$log - $!\n");
+    }
   }
 }
 
 
   }
 }
 
 
-
 sub badchar {
   my $bc = shift;
   
 sub badchar {
   my $bc = shift;
   
@@ -711,6 +777,9 @@ sub http_error {
   } elsif ($error eq 404) {
     http_error_header("404 Not Found");
     nvt_print("The requested URI $URI was not found on this server.");
   } elsif ($error eq 404) {
     http_error_header("404 Not Found");
     nvt_print("The requested URI $URI was not found on this server.");
+  } elsif ($error eq 413) {
+    http_error_header("413 Payload Too Large");
+    nvt_print("Your HTTP header is too large.");
   } elsif ($error eq 416) {
     http_error_header("416 Requested Range Not Satisfiable");
   } elsif ($error eq 503) {
   } elsif ($error eq 416) {
     http_error_header("416 Requested Range Not Satisfiable");
   } elsif ($error eq 503) {
@@ -765,6 +834,44 @@ sub http_error_header {
 }
 
 
 }
 
 
+sub redirect {
+  my $uri = shift;
+  my $r = shift;
+  my $rr = $redirect{$r};
+  my $newurl;
+  
+  $uri =~ s/\Q$r//;
+
+  if ($rr =~ s/^!//) {
+    $newurl = $rr.$uri;
+      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";
+    }
+  
+    http_header("200 OK");
+    print html_header("$hostname page has moved");
+    pq(qq(
+      '<h3>Please use new URL: <a href="$newurl">$newurl</a></h3>'
+      '</body></html>'
+    ));
+  }
+  if ($rr =~ /^http/) {
+    exit;
+  } else {
+    &reexec;
+  }
+}
+
+
 sub badlog {
   my $request = shift;
   my @n;
 sub badlog {
   my $request = shift;
   my @n;
Unofficial F*EX git repository tracking official releases.