Original release 20160919

[fex.git] / lib / fex.pp

diff --git a/lib/fex.pp b/lib/fex.pp
index c6f0562d4328e1a892cf299938321739eeca256d..177babac657e927a0cb175aa3d5785bb6363beae 100644 (file)
--- a/lib/fex.pp
+++ b/lib/fex.pp
@@ -1,6 +1,7 @@
 #  -*- perl -*-
 
 use 5.008;
 #  -*- perl -*-
 
 use 5.008;

+use utf8;

 use Fcntl              qw':flock :seek :mode';
 use IO::Handle;
 use IPC::Open3;
 use Fcntl              qw':flock :seek :mode';
 use IO::Handle;
 use IPC::Open3;


@@ -61,6 +62,18 @@ $fop_auth = 0;
 $mail_authid = 'yes';
 $force_https = 0;
 $debug = 0;
 $mail_authid = 'yes';
 $force_https = 0;
 $debug = 0;

+@forbidden_user_agents = ('FDM');
+
+# https://securityheaders.io/
+# https://scotthelme.co.uk/hardening-your-http-response-headers/
+# http://content-security-policy.com/
+@extra_header = (
+  # "Content-Security-Policy: sandbox allow-forms allow-scripts",
+  "Content-Security-Policy: script-src 'self' 'unsafe-inline'",
+  "X-Frame-Options: SAMEORIGIN",
+  "X-XSS-Protection: 1; mode=block",
+  "X-Content-Type-Options: nosniff",
+);

 
 $FHS = -f '/etc/fex/fex.ph' and -d '/usr/share/fex/lib';
 # Debian FHS
 
 $FHS = -f '/etc/fex/fex.ph' and -d '/usr/share/fex/lib';
 # Debian FHS


@@ -112,16 +125,17 @@ http_die("cannot determine the server hostname") unless $hostname;
 
 $ENV{PROTO} = 'http' unless $ENV{PROTO};
 $keep = $keep_default ||= $keep || 5;
 
 $ENV{PROTO} = 'http' unless $ENV{PROTO};
 $keep = $keep_default ||= $keep || 5;

+$purge ||= 3*$keep;

 $fra = $ENV{REMOTE_ADDR} || '';
 $sid = $ENV{SID} || '';
 
 $fra = $ENV{REMOTE_ADDR} || '';
 $sid = $ENV{SID} || '';
 

-mkdirp($dkeydir = "$spooldir/.dkeys"); # download keys
-mkdirp($ukeydir = "$spooldir/.ukeys"); # upload keys
-mkdirp($akeydir = "$spooldir/.akeys"); # authentification keys
-mkdirp($skeydir = "$spooldir/.skeys"); # subuser authentification keys
-mkdirp($gkeydir = "$spooldir/.gkeys"); # group authentification keys
-mkdirp($xkeydir = "$spooldir/.xkeys"); # extra download keys
-mkdirp($lockdir = "$spooldir/.locks"); # download lock files
+$dkeydir = "$spooldir/.dkeys"; # download keys
+$ukeydir = "$spooldir/.ukeys"; # upload keys
+$akeydir = "$spooldir/.akeys"; # authentification keys
+$skeydir = "$spooldir/.skeys"; # subuser authentification keys
+$gkeydir = "$spooldir/.gkeys"; # group authentification keys
+$xkeydir = "$spooldir/.xkeys"; # extra download keys
+$lockdir = "$spooldir/.locks"; # download lock files

 
 if (my $ra = $ENV{REMOTE_ADDR} and $max_fail) {
   mkdirp("$spooldir/.fail");
 
 if (my $ra = $ENV{REMOTE_ADDR} and $max_fail) {
   mkdirp("$spooldir/.fail");


@@ -276,15 +290,16 @@ sub http_header {
   nvt_print("Server: fexsrv");
   nvt_print("Expires: 0");
   nvt_print("Cache-Control: no-cache");
   nvt_print("Server: fexsrv");
   nvt_print("Expires: 0");
   nvt_print("Cache-Control: no-cache");

-  # http://en.wikipedia.org/wiki/Clickjacking
-  nvt_print("X-Frame-Options: SAMEORIGIN");

   if ($force_https) {
     # https://www.owasp.org/index.php/HTTP_Strict_Transport_Security
   if ($force_https) {
     # https://www.owasp.org/index.php/HTTP_Strict_Transport_Security

+    # https://scotthelme.co.uk/hsts-the-missing-link-in-tls/

     nvt_print("Strict-Transport-Security: max-age=2851200; preload");
   }
     nvt_print("Strict-Transport-Security: max-age=2851200; preload");
   }

+  nvt_print($_) foreach(@extra_header);

   if ($use_cookies) {
   if ($use_cookies) {

+    $akey = md5_hex("$from:$id") if $id and $from;

     if ($akey) {
     if ($akey) {

-      nvt_print("Set-Cookie: akey=$akey; Max-Age=9999; Discard");
+      nvt_print("Set-Cookie: akey=$akey; path=/; Max-Age=9999; Discard");

     }
     # if ($skey) {
     #   nvt_print("Set-Cookie: skey=$skey; Max-Age=9999; Discard");
     }
     # if ($skey) {
     #   nvt_print("Set-Cookie: skey=$skey; Max-Age=9999; Discard");


@@ -307,6 +322,8 @@ sub html_header {
   my $header = 'header.html';
   my $head;
 
   my $header = 'header.html';
   my $head;
 

+  binmode(STDOUT,':utf8'); # for text/html !
+

   # http://www.w3.org/TR/html401/struct/global.html
   # http://www.w3.org/International/O-charset
   $head = qqq(qq(
   # http://www.w3.org/TR/html401/struct/global.html
   # http://www.w3.org/International/O-charset
   $head = qqq(qq(


@@ -357,6 +374,12 @@ sub html_error {
 
   errorlog($msg);
 
 
   errorlog($msg);
 

+  $SIG{ALRM} = sub {
+    $SIG{__DIE__} = 'DEFAULT';
+    die "TIMEOUT\n";
+  };
+  alarm($timeout);
+

   # cannot send standard HTTP Status-Code 400, because stupid
   # Internet Explorer then refuses to display HTML body!
   http_header("666 Bad Request - $msg");
   # cannot send standard HTTP Status-Code 400, because stupid
   # Internet Explorer then refuses to display HTML body!
   http_header("666 Bad Request - $msg");


@@ -871,12 +894,15 @@ sub debuglog {
     $debuglog = sprintf("%s/%s_%s_%s.%s",
                         $ddir,time,$$,$ENV{REQUESTCOUNT}||0,$prg);
     $debuglog =~ s/\s/_/g;
     $debuglog = sprintf("%s/%s_%s_%s.%s",
                         $ddir,time,$$,$ENV{REQUESTCOUNT}||0,$prg);
     $debuglog =~ s/\s/_/g;

+    # http://perldoc.perl.org/perlunifaq.html#What-is-a-%22wide-character%22%3f

     # open $debuglog,'>>:encoding(UTF-8)',$debuglog or return;
     open $debuglog,'>>',$debuglog or return;
     # open $debuglog,'>>:encoding(UTF-8)',$debuglog or return;
     open $debuglog,'>>',$debuglog or return;

+    # binmode($debuglog,":utf8");

     autoflush $debuglog 1;
     # printf {$debuglog} "\n### %s ###\n",isodate(time);
   }
   while ($_ = shift @_) {
     autoflush $debuglog 1;
     # printf {$debuglog} "\n### %s ###\n",isodate(time);
   }
   while ($_ = shift @_) {

+    $_ = encode_utf8($_) if utf8::is_utf8($_);

     s/\n*$/\n/;
     s/<.+?>//g; # remove HTML
     print {$debuglog} $_;
     s/\n*$/\n/;
     s/<.+?>//g; # remove HTML
     print {$debuglog} $_;


@@ -948,11 +974,11 @@ sub qqq {
   my $q = "[\'\"]"; # quote delimiter chars " and '
 
   # remove first newline and look for default indention
   my $q = "[\'\"]"; # quote delimiter chars " and '
 
   # remove first newline and look for default indention

-  s/^(\«(\d+)?)?\n//;
+  s/^((\d+)?)?\n//;

   $i = ' ' x ($2||0);
 
   # remove trailing spaces at end
   $i = ' ' x ($2||0);
 
   # remove trailing spaces at end

-  s/[ \t]*\»?$//;
+  s/[ \t]*?$//;

 
   @s = split "\n";
 
 
   @s = split "\n";
 


@@ -1292,7 +1318,7 @@ sub gpg_encrypt {
     "    -a -e -r $bcc -r $to"
   ) or return;
 
     "    -a -e -r $bcc -r $to"
   ) or return;
 

-  print {$po} $plain;
+  print {$po} "\n",$plain,"\n";

   close $po;
 
   $enc .= $_ while <$pi>;
   close $po;
 
   $enc .= $_ while <$pi>;


@@ -1439,14 +1465,17 @@ sub notify {
   $data = "$dkeydir/$P{dkey}/data";
   $size = $bytes = -s $data;
   return unless $size;
   $data = "$dkeydir/$P{dkey}/data";
   $size = $bytes = -s $data;
   return unless $size;

-  if ($nowarning) {
-    $warning = '';
-  } else {
-    $warning =
-      "Please avoid download with Internet Explorer, ".
-      "because it has too many bugs.\n".
-      "We recommend Firefox or wget.";
-  }
+  $warning =
+    "We recommend fexget or fexit for download,\n".
+    "because these clients can resume the download after an interruption.\n".
+    "See $proto://$hostname/tools.html";
+  # if ($nowarning) {
+  #   $warning = '';
+  # } else {
+  #   $warning =
+  #     "Please avoid download with Internet Explorer, ".
+  #     "because it has too many bugs.\n\n";
+  # }

   if ($filename =~ /\.(tar|zip|7z|arj|rar)$/) {
     $warning .= "\n\n".
       "$filename is a container file.\n".
   if ($filename =~ /\.(tar|zip|7z|arj|rar)$/) {
     $warning .= "\n\n".
       "$filename is a container file.\n".


@@ -1543,17 +1572,16 @@ sub notify {
         or http_die("cannot start sendmail - $!");
     }
   }
         or http_die("cannot start sendmail - $!");
     }
   }

-  if ($comment =~ s/^!(shortmail|\.)!\s*//i
-    or (readlink "$to/\@NOTIFICATION"||'') =~ /short/i
+  $comment = "\n$comment\n" if $comment;
+  if ($comment =~ s/\n!(shortmail|\.)!\s*//i
+    or (readlink("$to/\@NOTIFICATION")||'') =~ /short/i

   ) {
     $body = qqq(qq(
       '$comment'
   ) {
     $body = qqq(qq(
       '$comment'

-      ''

       '$download'
       '$size'
     ));
   } else {
       '$download'
       '$size'
     ));
   } else {

-    $comment = "Comment: $comment\n" if $comment;

     $disclaimer = slurp("$from/\@DISCLAIMER") || qqq(qq(
       '$warning'
       ''
     $disclaimer = slurp("$from/\@DISCLAIMER") || qqq(qq(
       '$warning'
       ''


@@ -1562,8 +1590,9 @@ sub notify {
       ''
       'Questions? ==> F*EX admin: $admin'
     ));
       ''
       'Questions? ==> F*EX admin: $admin'
     ));

-    $disclaimer .= "\n" . $::disclaimer if $::disclaimer;
+    $disclaimer .= "\n$::disclaimer\n" if $::disclaimer;

     $body = qqq(qq(
     $body = qqq(qq(

+      '$comment'

       '$from has uploaded the file'
       '  "$filename"'
       '($size) for $receiver. Use'
       '$from has uploaded the file'
       '  "$filename"'
       '($size) for $receiver. Use'


@@ -1571,7 +1600,6 @@ sub notify {
       '$download'
       'to download this file within $days.'
       ''
       '$download'
       'to download this file within $days.'
       ''

-      '$comment'

       '$autodelete'
       ''
       '$disclaimer'
       '$autodelete'
       ''
       '$disclaimer'


@@ -1617,21 +1645,23 @@ sub notify {
 sub reactivation {
   my ($expire,$user) = @_;
   my $fexsend = "$FEXHOME/bin/fexsend";
 sub reactivation {
   my ($expire,$user) = @_;
   my $fexsend = "$FEXHOME/bin/fexsend";

+  my $reactivation = "$FEXLIB/reactivation.txt";

 
   return if $nomail;
 
   if (-x $fexsend) {
 
   return if $nomail;
 
   if (-x $fexsend) {

+    if ($locale) {
+      my $lr = "$FEXHOME/locale/$locale/lib/reactivation.txt";
+      $reactivation = $lr if -f $lr and -s $lr;
+    }

     $fexsend .= " -M -D -k 30 -C"
                ." 'Your F*EX account has been inactive for $expire days,"
                ." you must download this file to reactivate it."
                ." Otherwise your account will be deleted.'"
     $fexsend .= " -M -D -k 30 -C"
                ." 'Your F*EX account has been inactive for $expire days,"
                ." you must download this file to reactivate it."
                ." Otherwise your account will be deleted.'"

-               ." $FEXLIB/reactivation.txt $user";
+               ." $reactivation $user";

     # on error show STDOUT and STDERR
     # on error show STDOUT and STDERR

-    system "$fexsend >/dev/null 2>&1";
-    if ($?) {
-      warn "$fexsend\n";
-      system $fexsend;
-    }
+    my $fo = `$fexsend 2>&1`;
+    warn $fexsend.'\n'.$fo if $?;

   } else {
     warn "$0: cannot execute $fexsend for reactivation()\n";
   }
   } else {
     warn "$0: cannot execute $fexsend for reactivation()\n";
   }