]> git.treefish.org Git - fex.git/blob - lib/fex.pp
8bfddbf550276afad07c019c7c35b6820cd168f5
[fex.git] / lib / fex.pp
1 #  -*- perl -*-
2
3 use 5.008;
4 use utf8;
5 use Fcntl               qw':flock :seek :mode';
6 use IO::Handle;
7 use IPC::Open3;
8 use Encode;
9 use Digest::MD5         qw'md5_hex';
10 use File::Basename;
11 use Sys::Hostname;
12 use Symbol              qw'gensym';
13
14 # set and untaint ENV if not in CLI (fexsrv provides clean ENV)
15 unless (-t) {
16   foreach my $v (keys %ENV) {
17     ($ENV{$v}) = ($ENV{$v} =~ /(.*)/s) if defined $ENV{$v};
18   }
19   $ENV{PATH}     = '/usr/local/bin:/bin:/usr/bin';
20   $ENV{IFS}      = " \t\n";
21   $ENV{BASH_ENV} = '';
22 }
23
24 unless ($FEXLIB = $ENV{FEXLIB} and -d $FEXLIB) {
25   die "$0: found no FEXLIB - fexsrv needs full path\n"
26 }
27
28 $FEXLIB =~ s:/+:/:g;
29 $FEXLIB =~ s:/$::;
30
31 # $FEXHOME is top-level directory of F*EX installation or vhost
32 # $ENV{HOME} is login-directory of user fex
33 # in default-installation both are equal, but they may differ
34 $FEXHOME = $ENV{FEXHOME} or $ENV{FEXHOME} = $FEXHOME = dirname($FEXLIB);
35
36 umask 077;
37
38 # defaults
39 $hostname = gethostname();
40 $tmpdir = $ENV{TMPDIR} || '/var/tmp';
41 $spooldir = $FEXHOME.'/spool';
42 $docdir = $FEXHOME.'/htdocs';
43 $logdir = $spooldir;
44 $autodelete = 'YES';
45 $overwrite = 'YES';
46 $limited_download = 'YES';      # multiple downloads only from same client
47 $fex_yourself = 'YES';          # allow SENDER = RECIPIENT
48 $keep = 5;                      # days
49 $recipient_quota = 0;           # MB
50 $sender_quota = 0;              # MB
51 $timeout = 30;                  # seconds
52 $bs = 2**16;                    # I/O blocksize
53 $DS = 60*60*24;                 # seconds in a day
54 $MB = 1024*1024;                # binary Mega
55 $use_cookies = 1;
56 $sendmail = '/usr/lib/sendmail';
57 $sendmail = '/usr/sbin/sendmail' unless -x $sendmail;
58 $mailmode = 'auto';
59 $bcc = 'fex';
60 $default_locale = '';
61 $fop_auth = 0;
62 $mail_authid = 'yes';
63 $force_https = 0;
64 $debug = 0;
65
66 # https://securityheaders.io/
67 # https://scotthelme.co.uk/hardening-your-http-response-headers/
68 # http://content-security-policy.com/
69 @extra_header = (
70   # "Content-Security-Policy: sandbox allow-forms allow-scripts",
71   "Content-Security-Policy: script-src 'self' 'unsafe-inline'",
72   "X-Frame-Options: SAMEORIGIN",
73   "X-XSS-Protection: 1; mode=block",
74   "X-Content-Type-Options: nosniff",
75 );
76
77 $FHS = -f '/etc/fex/fex.ph' and -d '/usr/share/fex/lib';
78 # Debian FHS
79 if ($FHS) {
80   $ENV{FEXHOME} = $FEXHOME = '/usr/share/fex';
81   $spooldir = '/var/spool/fex';
82   $logdir = '/var/log/fex';
83   $docdir = '/var/lib/fex/htdocs';
84   $notify_newrelease = '';
85 }
86
87 # allowed download managers (HTTP User-Agent)
88 $adlm = '^(Axel|fex)';
89
90 # local config
91 require "$FEXLIB/fex.ph" or die "$0: cannot load $FEXLIB/fex.ph - $!";
92
93 $fop_auth       = 0 if $fop_auth        =~ /no/i;
94 $mail_authid    = 0 if $mail_authid     =~ /no/i;
95 $force_https    = 0 if $force_https     =~ /no/i;
96 $debug          = 0 if $debug           =~ /no/i;
97
98 @logdir = ($logdir) unless @logdir;
99 $logdir = $logdir[0];
100
101 # allowed multi download recipients: from any ip, any times
102 if (@mailing_lists) {
103   $amdl = '^('.join('|',map { quotewild($_) } @mailing_lists).')$';
104 } else {
105   $amdl = '^-$';
106 }
107
108 # check for name based virtual host
109 $vhost = vhost($ENV{'HTTP_HOST'});
110
111 $RB = 0; # read POST bytes
112
113 push @doc_dirs,$docdir;
114 foreach my $ld (glob "$FEXHOME/locale/*/htdocs") {
115   push @doc_dirs,$ld;
116 }
117
118 $nomail = ($mailmode =~ /^MANUAL|nomail$/i);
119
120 if (not $nomail and not -x $sendmail) {
121   http_die("found no sendmail");
122 }
123 http_die("cannot determine the server hostname") unless $hostname;
124
125 $ENV{PROTO} = 'http' unless $ENV{PROTO};
126 $keep = $keep_default ||= $keep || 5;
127 $fra = $ENV{REMOTE_ADDR} || '';
128 $sid = $ENV{SID} || '';
129
130 $dkeydir = "$spooldir/.dkeys"; # download keys
131 $ukeydir = "$spooldir/.ukeys"; # upload keys
132 $akeydir = "$spooldir/.akeys"; # authentification keys
133 $skeydir = "$spooldir/.skeys"; # subuser authentification keys
134 $gkeydir = "$spooldir/.gkeys"; # group authentification keys
135 $xkeydir = "$spooldir/.xkeys"; # extra download keys
136 $lockdir = "$spooldir/.locks"; # download lock files
137
138 if (my $ra = $ENV{REMOTE_ADDR} and $max_fail) {
139   mkdirp("$spooldir/.fail");
140   $faillog = "$spooldir/.fail/$ra";
141 }
142
143 unless ($admin) {
144   $admin = $ENV{SERVER_ADMIN} ? $ENV{SERVER_ADMIN} : 'fex@'.$hostname;
145 }
146
147 # $ENV{SERVER_ADMIN} may be set empty in fex.ph!
148 $ENV{SERVER_ADMIN} = $admin unless defined $ENV{SERVER_ADMIN};
149
150 $mdomain ||= '';
151
152 if ($use_cookies) {
153   if (my $cookie = $ENV{HTTP_COOKIE}) {
154     if    ($cookie =~ /\bakey=(\w+)/) { $akey = $1 }
155     # elsif ($cookie =~ /\bskey=(\w+)/) { $skey = $1 }
156   }
157 }
158
159 if (@locales) {
160   if ($default_locale and not grep /^$default_locale$/,@locales) {
161     push @locales,$default_locale;
162   }
163   if (@locales == 1) {
164     $default_locale = $locales[0];
165   }
166 }
167
168 $default_locale ||= 'english';
169
170 # $durl is first default fop download URL
171 # @durl is optional mandatory fop download URL list (from fex.ph)
172 unless ($durl) {
173   my $host = '';
174   my $port = 80;
175   my $xinetd = '/etc/xinetd.d/fex';
176
177   if (@durl) {
178     $durl = $durl[0];
179   } elsif ($ENV{HTTP_HOST} and $ENV{PROTO}) {
180
181     ($host,$port) = split(':',$ENV{HTTP_HOST}||'');
182     $host = $hostname;
183
184     unless ($port) {
185       $port = 80;
186       if (open $xinetd,$xinetd) {
187         while (<$xinetd>) {
188           if (/^\s*port\s*=\s*(\d+)/) {
189             $port = $1;
190             last;
191           }
192         }
193         close $xinetd;
194       }
195     }
196
197     # use same protocal as uploader for download
198     if ($ENV{PROTO} eq 'https' and $port == 443 or $port == 80) {
199       $durl = "$ENV{PROTO}://$host/fop";
200     } else {
201       $durl = "$ENV{PROTO}://$host:$port/fop";
202     }
203   } else {
204     if (open $xinetd,$xinetd) {
205       while (<$xinetd>) {
206         if (/^\s*port\s*=\s*(\d+)/) {
207           $port = $1;
208           last;
209         }
210       }
211       close $xinetd;
212     }
213     if ($port == 80) {
214       $durl = "http://$hostname/fop";
215     } else {
216       $durl = "http://$hostname:$port/fop";
217     }
218   }
219 }
220 @durl = ($durl) unless @durl;
221
222
223 sub reexec {
224   exec($FEXHOME.'/bin/fexsrv') if $ENV{KEEP_ALIVE};
225   exit;
226 }
227
228
229 sub jsredirect {
230   $url = shift;
231   $cont = shift || 'request accepted: continue';
232
233   http_header('200 ok');
234   print html_header($head||$ENV{SERVER_NAME});
235   pq(qq(
236     '<script type="text/javascript">'
237     '  window.location.replace("$url");'
238     '</script>'
239     '<noscript>'
240     '  <h3><a href="$url">$cont</a></h3>'
241     '</noscript>'
242     '</body></html>'
243   ));
244   &reexec;
245 }
246
247
248 sub debug {
249   print header(),"<pre>\n";
250   print "file = $file\n";
251   foreach $v (keys %ENV) {
252     print $v,' = "',$ENV{$v},"\"\n";
253   }
254   print "</pre><p>\n";
255 }
256
257
258 sub nvt_print {
259   foreach (@_) { syswrite STDOUT,"$_\r\n" }
260 }
261
262
263 sub html_quote {
264   local $_ = shift;
265
266   s/&/&amp;/g;
267   s/</&lt;/g;
268   s/\"/&quot;/g;
269
270   return $_;
271 }
272
273
274
275 sub http_header {
276
277   my $status = shift;
278   my $msg = $status;
279
280   return if $HTTP_HEADER;
281   $HTTP_HEADER = $status;
282
283   $msg =~ s/^\d+\s*//;
284
285   nvt_print("HTTP/1.1 $status");
286   nvt_print("X-Message: $msg");
287   # nvt_print("X-SID: $ENV{SID}") if $ENV{SID};
288   nvt_print("Server: fexsrv");
289   nvt_print("Expires: 0");
290   nvt_print("Cache-Control: no-cache");
291   if ($force_https) {
292     # https://www.owasp.org/index.php/HTTP_Strict_Transport_Security
293     # https://scotthelme.co.uk/hsts-the-missing-link-in-tls/
294     nvt_print("Strict-Transport-Security: max-age=2851200; preload");
295   }
296   nvt_print($_) foreach(@extra_header);
297   if ($use_cookies) {
298     $akey = md5_hex("$from:$id") if $id and $from;
299     if ($akey) {
300       nvt_print("Set-Cookie: akey=$akey; path=/; Max-Age=9999; Discard");
301     }
302     # if ($skey) {
303     #   nvt_print("Set-Cookie: skey=$skey; Max-Age=9999; Discard");
304     # }
305     if ($locale) {
306       nvt_print("Set-Cookie: locale=$locale");
307     }
308   }
309   unless (grep /^Content-Type:/i,@_) {
310     # nvt_print("Content-Type: text/html; charset=ISO-8859-1");
311     nvt_print("Content-Type: text/html; charset=UTF-8");
312   }
313
314   nvt_print(@_,'');
315 }
316
317
318 sub html_header {
319   my $title = shift;
320   my $header = 'header.html';
321   my $head;
322
323   # http://www.w3.org/TR/html401/struct/global.html
324   # http://www.w3.org/International/O-charset
325   $head = qqq(qq(
326     '<html>'
327     '<head>'
328     '  <meta http-equiv="expires" content="0">'
329     '  <meta http-equiv="Content-Type" content="text/html;charset=utf-8">'
330     '  <title>$title</title>'
331     '</head>'
332   ));
333   # '<!-- <style type="text/css">\@import "/fex.css";</style> -->'
334
335   if ($0 =~ /fexdev/) { $head .= "<body bgcolor=\"pink\">\n" }
336   else                { $head .= "<body>\n" }
337
338   $title =~ s:F\*EX:<a href="/index.html">F*EX</a>:;
339
340   if (open $header,'<',"$docdir/$header") {
341     $head .= $_ while <$header>;
342     close $header;
343   }
344
345   $head .= &$prolog($title) if defined($prolog);
346
347   if (@H1_extra) {
348     $head .= sprintf(
349       '<h1><a href="%s"><img align=center src="%s" border=0></a>%s</h1>',
350       $H1_extra[0],$H1_extra[1]||'',$title
351     );
352   } else {
353     $head .= "<h1>$title</h1>";
354   }
355   $head .= "\n";
356
357   return $head;
358 }
359
360
361 sub html_error {
362   my $error = shift;
363   my $msg = "@_";
364   my @msg = @_;
365   my $isodate = isodate(time);
366
367   $msg =~ s/[\s\n]+/ /g;
368   $msg =~ s/<.+?>//g; # remove HTML
369   map { s/<script.*?>//gi } @msg;
370
371   errorlog($msg);
372
373   # cannot send standard HTTP Status-Code 400, because stupid
374   # Internet Explorer then refuses to display HTML body!
375   http_header("666 Bad Request - $msg");
376   print html_header($error);
377   print 'ERROR: ',join("<p>\n",@msg),"\n";
378   pq(qq(
379     '<p><hr><p>'
380     '<address>
381     '  $ENV{HTTP_HOST}'
382     '  $isodate'
383     '  <a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>'
384     '</address>'
385     '</body></html>'
386   ));
387   exit;
388 }
389
390
391 sub http_die {
392
393   # not in CGI mode
394   unless ($ENV{GATEWAY_INTERFACE}) {
395     warn "$0: @_\n"; # must not die, because of fex_cleanup!
396     return;
397   }
398
399   debuglog(@_);
400
401   # create special error file on upload
402   if ($uid) {
403     my $ukey = "$spooldir/.ukeys/$uid";
404     $ukey .= "/error" if -d $ukey;
405     unlink $ukey;
406     if (open $ukey,'>',$ukey) {
407       print {$ukey} join("\n",@_),"\n";
408       close $ukey;
409     }
410   }
411
412   html_error($error||'',@_);
413 }
414
415
416 sub check_maint {
417   if (my $status = readlink '@MAINTENANCE') {
418     my $isodate = isodate(time);
419     http_header('666 MAINTENANCE');
420     print html_header($head||'');
421     pq(qq(
422       "<center>"
423       "<h1>Server is in maintenance mode</h1>"
424       "<h3>($status)</h3>"
425       "</center>"
426       "<p><hr><p>"
427       "<address>$ENV{HTTP_HOST} $isodate</address>"
428       "</body></html>"
429     ));
430     exit;
431   }
432 }
433
434
435 sub check_status {
436   my $user = shift;
437
438   $user = lc $user;
439   $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
440
441   if (-e "$user/\@DISABLED") {
442     my $isodate = isodate(time);
443     http_header('666 DISABLED');
444     print html_header($head);
445     pq(qq(
446       "<h3>$user is disabled</h3>"
447       "Contact $ENV{SERVER_ADMIN} for details"
448       "<p><hr><p>"
449       "<address>$ENV{HTTP_HOST} $isodate</address>"
450       "</body></html>"
451     ));
452     exit;
453   }
454 }
455
456
457 sub isodate {
458   my @d = localtime shift;
459   return sprintf('%d-%02d-%02d %02d:%02d:%02d',
460                  $d[5]+1900,$d[4]+1,$d[3],$d[2],$d[1],$d[0]);
461 }
462
463
464 sub encode_Q {
465   my $s = shift;
466   $s =~ s{([\=\x00-\x20\x7F-\xA0])}{sprintf("=%02X",ord($1))}eog;
467   return $s;
468 }
469
470
471 # from MIME::Base64::Perl
472 sub decode_b64 {
473   local $_ = shift;
474   my $uu = '';
475   my ($i,$l);
476
477   tr|A-Za-z0-9+=/||cd;
478   s/=+$//;
479   tr|A-Za-z0-9+/| -_|;
480   return '' unless length;
481   $l = (length)-60;
482   for ($i = 0; $i <= $l; $i += 60) {
483     $uu .= "M" . substr($_,$i,60);
484   }
485   $_ = substr($_,$i);
486   $uu .= chr(32+(length)*3/4) . $_ if $_;
487   return unpack ("u",$uu);
488 }
489
490
491 # short base64 encoding
492 sub b64 {
493   local $_ = '';
494   my $x = 0;
495
496   pos($_[0]) = 0;
497   $_ = join '',map(pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs));
498   tr|` -_|AA-Za-z0-9+/|;
499   $x = (3 - length($_[0]) % 3) % 3;
500   s/.{$x}$//;
501
502   return $_;
503 }
504
505
506 # simulate a "rm -rf", but never removes '..'
507 # return number of removed files
508 sub rmrf {
509   my @files = @_;
510   my $dels = 0;
511   my ($file,$dir);
512   local *D;
513   local $_;
514
515   foreach (@files) {
516     next if /(^|\/)\.\.$/;
517     /(.*)/; $file = $1;
518     if (-d $file and not -l $file) {
519       $dir = $file;
520       opendir D,$dir or next;
521       while ($file = readdir D) {
522         next if $file eq '.' or $file eq '..';
523         $dels += rmrf("$dir/$file");
524       }
525       closedir D;
526       rmdir $dir and $dels++;
527     } else {
528       unlink $file and $dels++;
529     }
530   }
531   return $dels;
532 }
533
534
535 sub gethostname {
536   my $hostname = hostname;
537   my $domain;
538   local $_;
539
540   unless ($hostname) {
541     $_ = `hostname 2>/dev/null`;
542     $hostname = /(.+)/ ? $1 : '';
543   }
544   if ($hostname !~ /\./ and open my $rc,'/etc/resolv.conf') {
545     while (<$rc>) {
546       if (/^\s*domain\s+([\w.-]+)/) {
547         $domain = $1;
548         last;
549       }
550       if (/^\s*search\s+([\w.-]+)/) {
551         $domain = $1;
552       }
553     }
554     close $rc;
555     $hostname .= ".$domain" if $domain;
556   }
557   if ($hostname !~ /\./ and $admin and $admin =~ /\@([\w.-]+)/) {
558     $hostname .= '.'.$1;
559   }
560
561   return $hostname;
562 }
563
564
565 # strip off path names (Windows or UNIX)
566 sub strip_path {
567   local $_ = shift;
568
569   s/.*\\// if /^([A-Z]:)?\\/;
570   s:.*/::;
571
572   return $_;
573 }
574
575
576 # substitute all critcal chars
577 sub normalize {
578   local $_ = shift;
579
580   return '' unless defined $_;
581
582   # we need perl native utf8 (see perldoc utf8)
583   $_ = decode_utf8($_) unless utf8::is_utf8($_);
584
585   s/[\r\n\t]+/ /g;
586   s/[\x00-\x1F\x80-\x9F]/_/g;
587   s/^\s+//;
588   s/\s+$//;
589
590   return encode_utf8($_);
591 }
592
593
594 # substitute all critcal chars
595 sub normalize_html {
596   local $_ = shift;
597
598   return '' unless defined $_;
599
600   $_ = normalize($_);
601   s/[\"<>]//g;
602
603   return $_;
604 }
605
606
607
608 # substitute all critcal chars with underscore
609 sub normalize_filename {
610   local $_ = shift;
611
612   return $_ unless $_;
613
614   # we need native utf8
615   $_ = decode_utf8($_) unless utf8::is_utf8($_);
616
617   $_ = strip_path($_);
618
619   # substitute all critcal chars with underscore
620   s/[^a-zA-Z0-9_=.+-]/_/g;
621   s/^\./_/;
622
623   return encode_utf8($_);
624 }
625
626
627 sub normalize_email {
628   local $_ = lc shift;
629
630   s/[^\w_.+=!~#^\@\-]//g;
631   s/^\./_/;
632   /(.*)/;
633   return $1;
634 }
635
636
637 sub normalize_user {
638   my $user = shift;
639
640   $user = lc(urldecode(despace($user)));
641   $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
642   checkaddress($user) or http_die("$user is not a valid e-mail address");
643   return untaint($user);
644 }
645
646
647 sub urldecode {
648   local $_ = shift;
649   s/%([a-f0-9]{2})/chr(hex($1))/gie;
650   return $_;
651 }
652
653
654 sub untaint {
655   local $_ = shift;
656   /(.*)/s;
657   return $1;
658 }
659
660
661 sub checkchars {
662   my $input = shift;
663   local $_ = shift;
664
665   if (/^([|+.])/) {
666     http_die("\"$1\" is not allowed at beginning of $input");
667   }
668   if (/([\/\"\'\\<>;])/) {
669     http_die(sprintf("\"&#%s;\" is not allowed in %s",ord($1),$input));
670   }
671   if (/(\|)$/) {
672     http_die("\"$1\" is not allowed at end of $input");
673   }
674   if (/[\000-\037]/) {
675     http_die("control characters are not allowed in $input");
676   }
677   /(.*)/;
678   return $1;
679 }
680
681
682 sub checkaddress {
683   my $a = shift;
684   my $re;
685   local $_;
686   local ($domain,$dns);
687
688   $a =~ s/:\w+=.*//; # remove options from address
689
690   return $a if $a eq 'anonymous';
691
692   $a .= '@'.$mdomain if $mdomain and $a !~ /@/;
693
694   $re = '^[.@-]|@.*@|local(host|domain)$|["\'\`\|\s()<>/;,]';
695   if ($a =~ /$re/i) {
696     debuglog("$a has illegal syntax ($re)");
697     return '';
698   }
699   $re = '^[!^=~#_:.+*{}\w\-\[\]]+\@(\w[.\w\-]*\.[a-z]+)$';
700   if ($a =~ /$re/i) {
701     $domain = $dns = $1;
702     {
703       local $SIG{__DIE__} = sub { die "\n" };
704       eval q{
705         use Net::DNS;
706         $dns = Net::DNS::Resolver->new->query($domain)||mx($domain);
707         unless ($dns or mx('uni-stuttgart.de')) {
708           http_die("Internal error: bad resolver");
709         }
710       }
711     };
712     if ($dns) {
713       return untaint($a);
714     } else {
715       debuglog("no A or MX DNS record found for $domain");
716       return '';
717     }
718   } else {
719     debuglog("$a does not match e-mail regexp ($re)");
720     return '';
721   }
722 }
723
724
725 # check forbidden addresses
726 sub checkforbidden {
727   my $a = shift;
728   my ($fr,$pr);
729   local $_;
730
731   $a .= '@'.$mdomain if $mdomain and $a !~ /@/;
732   return $a if -d "$spooldir/$a"; # ok, if user already exists
733   if (@forbidden_recipients) {
734     foreach (@forbidden_recipients) {
735       $fr = quotewild($_);
736       # skip public recipients
737       if (@public_recipients) {
738         foreach $pr (@public_recipients) {
739           return $a if $a eq lc $pr;
740         }
741       }
742       return '' if $a =~ /^$fr$/i;
743     }
744   }
745   return $a;
746 }
747
748
749 sub randstring {
750   my $n = shift;
751   my @rc = ('A'..'Z','a'..'z',0..9 );
752   my $rn = @rc;
753   my $rs;
754
755   for (1..$n) { $rs .= $rc[int(rand($rn))] };
756   return $rs;
757 }
758
759
760 # emulate mkdir -p
761 sub mkdirp {
762   my $dir = shift;
763   my $pdir;
764
765   return if -d $dir;
766   $dir =~ s:/+$::;
767   http_die("cannot mkdir /") unless $dir;
768   $pdir = $dir;
769   if ($pdir =~ s:/[^/]+$::) {
770     mkdirp($pdir) unless -d $pdir;
771   }
772   unless (-d $dir) {
773     mkdir $dir,0770 or http_die("mkdir $dir - $!");
774   }
775 }
776
777
778 # hash with SID
779 sub sidhash {
780   my ($rid,$id) = @_;
781
782   if ($rid and $ENV{SID} and $id =~ /^MD5H:/) {
783     $rid = 'MD5H:'.md5_hex($rid.$ENV{SID});
784   }
785   return $rid;
786 }
787
788
789 # test if ip is in iplist (ipv4/ipv6)
790 # iplist is an array with ips and ip-ranges
791 sub ipin {
792   my ($ip,@list) = @_;
793   my ($i,$ia,$ib);
794
795   $ipe = lc(ipe($ip));
796   map { lc } @list;
797
798   foreach $i (@list) {
799     if ($ip =~ /\./ and $i =~ /\./ or $ip =~ /:/ and $i =~ /:/) {
800       if ($i =~ /(.+)-(.+)/) {
801         ($ia,$ib) = ($1,$2);
802         $ia = ipe($ia);
803         $ib = ipe($ib);
804         return $ip if $ipe ge $ia and $ipe le $ib;
805       } else {
806         return $ip if $ipe eq ipe($i);
807       }
808     }
809   }
810   return '';
811 }
812
813 # ip expand (ipv4/ipv6)
814 sub ipe {
815   local $_ = shift;
816
817   if (/^\d+\.\d+\.\d+\.\d+$/) {
818     s/\b(\d\d?)\b/sprintf "%03d",$1/ge;
819   } elsif (/^[:\w]+:\w+$/) {
820     s/\b(\w+)\b/sprintf "%04s",$1/ge;
821     s/^:/0000:/;
822     while (s/::/::0000:/) { last if length > 39 }
823     s/::/:/;
824   } else {
825     $_ = '';
826   }
827   return $_;
828 }
829
830
831 sub filename {
832   my $file = shift;
833   my $filename;
834
835   if (open $file,'<',"$file/filename") {
836     $filename = <$file>||'';
837     chomp $filename;
838     close $file;
839   }
840
841   unless ($filename) {
842     $filename = $file;
843     $filename =~ s:.*/::;
844   }
845
846   return $filename;
847 }
848
849
850 sub urlencode {
851   local $_ = shift;
852   s/(^[.~]|[^\w.,=:~^+-])/sprintf "%%%X",ord($1)/ge;
853   return $_;
854 }
855
856
857 # file and document log
858 sub fdlog {
859   my ($log,$file,$s,$size) = @_;
860   my $ra = $ENV{REMOTE_ADDR}||'-';
861   my $msg;
862
863   $ra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
864   $ra =~ s/\s//g;
865   $file =~ s:/data$::;
866   $msg = sprintf "%s [%s_%s] %s %s %s/%s\n",
867          isodate(time),$$,$ENV{REQUESTCOUNT},$ra,encode_Q($file),$s,$size;
868
869   writelog($log,$msg);
870 }
871
872
873 # extra debug log
874 sub debuglog {
875   my $prg = $0;
876   local $_;
877
878   return unless $debug and @_;
879   unless ($debuglog and fileno $debuglog) {
880     my $ddir = "$spooldir/.debug";
881     mkdir $ddir,0770 unless -d $ddir;
882     $prg =~ s:.*/::;
883     $prg = untaint($prg);
884     $debuglog = sprintf("%s/%s_%s_%s.%s",
885                         $ddir,time,$$,$ENV{REQUESTCOUNT}||0,$prg);
886     $debuglog =~ s/\s/_/g;
887     # http://perldoc.perl.org/perlunifaq.html#What-is-a-%22wide-character%22%3f
888     # open $debuglog,'>>:encoding(UTF-8)',$debuglog or return;
889     open $debuglog,'>>',$debuglog or return;
890     # binmode($debuglog,":utf8");
891     autoflush $debuglog 1;
892     # printf {$debuglog} "\n### %s ###\n",isodate(time);
893   }
894   while ($_ = shift @_) {
895     $_ = encode_utf8($_) if utf8::is_utf8($_);
896     s/\n*$/\n/;
897     s/<.+?>//g; # remove HTML
898     print {$debuglog} $_;
899     print "DEBUG: $_" if -t;
900   }
901 }
902
903
904 # extra debug log
905 sub errorlog {
906   my $prg = $0;
907   my $msg = "@_";
908   my $ra = $ENV{REMOTE_ADDR}||'-';
909
910   $ra .= '/'.$ENV{HTTP_X_FORWARDED_FOR} if $ENV{HTTP_X_FORWARDED_FOR};
911   $ra =~ s/\s//g;
912   $prg =~ s:.*/::;
913   $msg =~ s/[\r\n]+$//;
914   $msg =~ s/[\r\n]+/ /;
915   $msg =~ s/\s*<p>.*//;
916   $msg = sprintf "%s %s %s %s\n",isodate(time),$prg,$ra,$msg;
917
918   writelog('error.log',$msg);
919 }
920
921
922 sub writelog {
923   my $log = shift;
924   my $msg = shift;
925
926   foreach my $logdir (@logdir) {
927     if (open $log,'>>',"$logdir/$log") {
928       flock $log,LOCK_EX;
929       seek $log,0,SEEK_END;
930       print {$log} $msg;
931       close $log;
932     }
933   }
934 }
935
936
937 # failed authentification log
938 sub faillog {
939   my $request = shift;
940   my $n = 1;
941
942   if ($faillog and $max_fail_handler and open $faillog,"+>>$faillog") {
943     flock($faillog,LOCK_EX);
944     seek $faillog,0,SEEK_SET;
945     $n++ while <$faillog>;
946     printf {$faillog} "%s %s\n",isodate(time),$request;
947     close $faillog;
948     &$max_fail_handler($ENV{REMOTE_ADDR}) if $n > $max_fail;
949   }
950 }
951
952 # remove all white space
953 sub despace {
954   local $_ = shift;
955   s/\s//g;
956   return $_;
957 }
958
959
960 # superquoting
961 sub qqq {
962   local $_ = shift;
963   my ($s,$i,@s);
964   my $q = "[\'\"]"; # quote delimiter chars " and '
965
966   # remove first newline and look for default indention
967   s/^((\d+)?)?\n//;
968   $i = ' ' x ($2||0);
969
970   # remove trailing spaces at end
971   s/[ \t]*?$//;
972
973   @s = split "\n";
974
975   # first line have a quote delimiter char?
976   if (/^\s+$q/) {
977     # remove heading spaces and delimiter chars
978     foreach (@s) {
979       s/^\s*$q//;
980       s/$q\s*$//;
981     }
982   } else {
983     # find the line with the fewest heading spaces (and count them)
984     # (beware of tabs!)
985     $s = length;
986     foreach (@s) {
987       if (/^( *)\S/ and length($1) < $s) { $s = length($1) };
988     }
989     # adjust indention
990     foreach (@s) {
991       s/^ {$s}/$i/;
992     }
993   }
994
995   return join("\n",@s)."\n";
996 }
997
998
999 # print superquoted
1000 sub pq {
1001   my $H = STDOUT;
1002
1003   if (@_ > 1 and defined fileno $_[0]) { $H = shift }
1004   binmode($H,':utf8');
1005   print {$H} qqq(@_);
1006 }
1007
1008
1009 # check sender quota
1010 sub check_sender_quota {
1011   my $sender = shift;
1012   my $squota = $sender_quota||0;
1013   my $du = 0;
1014   my ($file,$size,%file,$data,$upload);
1015   local $_;
1016
1017   if (open $qf,'<',"$sender/\@QUOTA") {
1018     while (<$qf>) {
1019       s/#.*//;
1020       $squota = $1 if /sender.*?(\d+)/i;
1021     }
1022     close $qf;
1023   }
1024
1025   foreach $file (glob "*/$sender/*") {
1026     $data = "$file/data";
1027     $upload = "$file/upload";
1028     if (not -l $data and $size = -s $data) {
1029       # count hard links only once (= same inode)
1030       my $i = (stat($data))[1]||0;
1031       unless ($file{$i}) {
1032         $du += $size;
1033         $file{$i} = $i;
1034       }
1035     } elsif (-f $upload) {
1036       # count hard links only once (= same inode)
1037       my $i = (stat($upload))[1]||0;
1038       unless ($file{$i}) {
1039         $size = readlink "$file/size" and $du += $size;
1040         $file{$i} = $i;
1041       }
1042     }
1043   }
1044
1045   return($squota,int($du/1024/1024));
1046 }
1047
1048
1049 # check recipient quota
1050 sub check_recipient_quota {
1051   my $recipient = shift;
1052   my $rquota = $recipient_quota||0;
1053   my $du = 0;
1054   my ($file,$size);
1055   local $_;
1056
1057   if (open my $qf,'<',"$recipient/\@QUOTA") {
1058     while (<$qf>) {
1059       s/#.*//;
1060       $rquota = $1 if /recipient.*?(\d+)/i;
1061     }
1062     close $qf;
1063   }
1064
1065   foreach $file (glob "$recipient/*/*") {
1066     if (-f "$file/upload" and $size = readlink "$file/size") {
1067       $du += $size;
1068     } elsif (not -l "$file/data" and $size = -s "$file/data") {
1069       $du += $size;
1070     }
1071   }
1072
1073   return($rquota,int($du/1024/1024));
1074 }
1075
1076
1077 sub getline {
1078   my $file = shift;
1079   local $_;
1080   chomp($_ = <$file>||'');
1081   return $_;
1082 }
1083
1084
1085 # (shell) wildcard matching
1086 sub wcmatch {
1087   local $_ = shift;
1088   my $p = quotemeta shift;
1089
1090   $p =~ s/\\\*/.*/g;
1091   $p =~ s/\\\?/./g;
1092   $p =~ s/\\\[/[/g;
1093   $p =~ s/\\\]/]/g;
1094
1095   return /$p/;
1096 }
1097
1098
1099 sub logout {
1100   my $logout;
1101   if    ($skey) { $logout = "/fup?logout=skey:$skey" }
1102   elsif ($gkey) { $logout = "/fup?logout=gkey:$gkey" }
1103   elsif ($akey) { $logout = "/fup?logout=akey:$akey" }
1104   else          { $logout = "/fup?logout" }
1105   return qqq(qq(
1106     '<p>'
1107     '<form name="logout" action="$logout">'
1108     '  <input type="submit" name="logout" value="logout">'
1109     '</form>'
1110     '<p>'
1111   ));
1112 }
1113
1114
1115 # print data dump of global or local variables in HTML
1116 # input musst be a string, eg: '%ENV'
1117 sub DD {
1118   my $v = shift;
1119   local $_;
1120
1121   $n =~ s/.//;
1122   $_ = eval(qq(use Data::Dumper;Data::Dumper->Dump([\\$v])));
1123   s/\$VAR1/$v/;
1124   s/&/&amp;/g;
1125   s/</&lt;/g;
1126   print "<pre>\n$_\n</pre>\n";
1127 }
1128
1129 # make symlink
1130 sub mksymlink {
1131   my ($file,$link) = @_;
1132   unlink $file;
1133   return symlink untaint($link),$file;
1134 }
1135
1136
1137 # copy file (and modify) or symlink
1138 # returns chomped file contents or link name
1139 # preserves permissions and time stamps
1140 sub copy {
1141   my ($from,$to,$mod) = @_;
1142   my $link;
1143   local $/;
1144   local $_;
1145
1146   $to .= '/'.basename($from) if -d $to;
1147
1148   if (defined($link = readlink $from)) {
1149     mksymlink($to,$link);
1150     return $link;
1151   } else {
1152     open $from,'<',$from or return;
1153     open $to,'>',$to or return;
1154     $_ = <$from>;
1155     close $from;
1156     eval $mod if $mod;
1157     print {$to} $_;
1158     close $to or http_die("internal error: $to - $!");
1159     if (my @s = stat($from)) {
1160       chmod $s[2],$to;
1161       utime @s[8,9],$to unless $mod;
1162     }
1163     chomp;
1164     return $_;
1165   }
1166 }
1167
1168
1169 sub slurp {
1170   my $file = shift;
1171   local $_;
1172   local $/;
1173
1174   if (open $file,$file) {
1175     $_ = <$file>;
1176     close $file;
1177   }
1178
1179   return $_;
1180 }
1181
1182
1183 # read one line from STDIN (net socket) and assign it to $_
1184 # return number of read bytes
1185 # also set global variable $RB (read bytes)
1186 sub nvt_read {
1187   my $len = 0;
1188
1189   if (defined ($_ = <STDIN>)) {
1190     debuglog($_);
1191     $len = length;
1192     $RB += $len;
1193     s/\r?\n//;
1194   }
1195   return $len;
1196 }
1197
1198
1199 # read forward to given pattern
1200 sub nvt_skip_to {
1201   my $pattern = shift;
1202
1203   while (&nvt_read) { return if /$pattern/ }
1204 }
1205
1206
1207 # HTTP GET and POST parameters
1208 # (not used by fup)
1209 # fills global variable %PARAM :
1210 # normal parameter is $PARAM{$parameter}
1211 # file parameter is $PARAM{$parameter}{filename} $PARAM{$parameter}{data}
1212 sub parse_parameters {
1213   my $cl = $ENV{X_CONTENT_LENGTH} || $ENV{CONTENT_LENGTH} || 0;
1214   my $data = '';
1215   my $filename;
1216   local $_;
1217
1218   if ($cl > 128*$MB) {
1219     http_die("request too large");
1220   }
1221
1222   binmode(STDIN,':raw');
1223
1224   foreach (split('&',$ENV{QUERY_STRING})) {
1225     if (/(.+?)=(.*)/) { $PARAM{$1} = $2 }
1226     else              { $PARAM{$_} = $_ }
1227   }
1228   $_ = $ENV{CONTENT_TYPE}||'';
1229   if ($ENV{REQUEST_METHOD} eq 'POST' and /boundary=\"?([\w\-\+\/_]+)/) {
1230     my $boundary = $1;
1231     while ($RB<$cl and &nvt_read) { last if /^--\Q$boundary/ }
1232     # continuation lines are not checked!
1233     while ($RB<$cl and &nvt_read) {
1234       $filename = '';
1235       if (/^Content-Disposition:.*\s*filename="(.+?)"/i) {
1236         $filename = $1;
1237       }
1238       if (/^Content-Disposition:\s*form-data;\s*name="(.+?)"/i) {
1239         my $p = $1;
1240         # skip rest of mime part header
1241         while ($RB<$cl and &nvt_read) { last if /^\s*$/ }
1242         $data = '';
1243         while (<STDIN>) {
1244           if ($p =~ /password/i) {
1245             debuglog('*' x length)
1246           } else {
1247             debuglog($_)
1248           }
1249           $RB += length;
1250           last if /^--\Q$boundary/;
1251           $data .= $_;
1252         }
1253         unless (defined $_) { die "premature end of HTTP POST\n" }
1254         $data =~ s/\r?\n$//;
1255         if ($filename) {
1256           $PARAM{$p}{filename} = $filename;
1257           $PARAM{$p}{data} = $data;
1258         } else {
1259           $PARAM{$p} = $data;
1260         }
1261         last if /^--\Q$boundary--/;
1262       }
1263     }
1264   }
1265 }
1266
1267
1268 # name based virtual host?
1269 sub vhost {
1270   my $hh = shift; # HTTP_HOST
1271   my $vhost;
1272   my $locale = $ENV{LOCALE};
1273
1274   # memorized vhost? (default is in fex.ph)
1275   %vhost = split(':',$ENV{VHOST}) if $ENV{VHOST};
1276
1277   if (%vhost and $hh and $hh =~ s/^([\w\.-]+).*/$1/) {
1278     if ($vhost = $vhost{$hh} and -f "$vhost/lib/fex.ph") {
1279       $ENV{VHOST} = "$hh:$vhost"; # memorize vhost for next run
1280       $ENV{FEXLIB} = $FEXLIB = "$vhost/lib";
1281       $logdir = $spooldir    = "$vhost/spool";
1282       $docdir                = "$vhost/htdocs";
1283       @logdir = ($logdir);
1284       if ($locale and -e "$vhost/locale/$locale/lib/fex.ph") {
1285         $ENV{FEXLIB} = $FEXLIB = "$vhost/locale/$locale/lib";
1286       }
1287       require "$FEXLIB/fex.ph" or die "$0: cannot load $FEXLIB/fex.ph - $!";
1288       $ENV{SERVER_NAME} = $hostname;
1289       @doc_dirs = ($docdir);
1290       foreach my $ld (glob "$FEXHOME/locale/*/htdocs") {
1291         push @doc_dirs,$ld;
1292       }
1293       return $vhost;
1294     }
1295   }
1296 }
1297
1298
1299 sub gpg_encrypt {
1300   my ($plain,$to,$keyring,$from) = @_;
1301   my ($pid,$pi,$po,$pe,$enc,$err);
1302   local $_;
1303
1304   $pe = gensym;
1305
1306   $pid = open3($po,$pi,$pe,
1307     "gpg --batch --trust-model always --keyring $keyring".
1308     "    -a -e -r $bcc -r $to"
1309   ) or return;
1310
1311   print {$po} "\n",$plain,"\n";
1312   close $po;
1313
1314   $enc .= $_ while <$pi>;
1315   $err .= $_ while <$pe>;
1316   errorlog("($from --> $to) $err") if $err;
1317
1318   close $pi;
1319   close $pe;
1320   waitpid($pid,0);
1321
1322   return $enc;
1323 }
1324
1325
1326 sub mtime {
1327   my @s = stat(shift) or return;
1328   return $s[9];
1329 }
1330
1331
1332 # wildcard * to perl regexp
1333 sub quotewild {
1334   local $_ = quotemeta shift;
1335   s/\\\*/.*/g; # allow wildcard *
1336   return $_;
1337 }
1338
1339
1340 # extract locale functions into hash of subroutine references
1341 # e.g. \&german ==> $notify{german}
1342 sub locale_functions {
1343   my $locale = shift;
1344   local $/;
1345   local $_;
1346
1347   if ($locale and open my $fexpp,"$FEXHOME/locale/$locale/lib/fex.pp") {
1348     $_ = <$fexpp>;
1349     s/.*\n(\#\#\# locale functions)/$1/s;
1350     # sub xx {} ==> xx{$locale} = sub {}
1351     s/\nsub (\w+)/\n\$$1\{$locale\} = sub/gs;
1352     s/\n}\n/\n};\n/gs;
1353     eval $_;
1354     close $fexpp;
1355   }
1356 }
1357
1358 sub notify_locale {
1359   my $dkey = shift;
1360   my $status = shift || 'new';
1361   my ($to,$keep,$locale,$file,$filename,$comment,$autodelete,$replyto,$mtime);
1362   local $_;
1363
1364   if ($dkey =~ m:/.+/.+/:) {
1365     $file = $dkey;
1366     $dkey = readlink("$file/dkey");
1367   } else {
1368     $file = readlink("$dkeydir/$dkey")
1369       or http_die("internal error: no DKEY $DKEY");
1370   }
1371   $file =~ s:^../::;
1372   $filename = filename($file);
1373   $to = $file;
1374   $to =~ s:/.*::;
1375   $mtime = mtime("$file/data") or http_die("internal error: no $file/data");
1376   $comment = slurp("$file/comment") || '';
1377   $replyto = readlink "$file/replyto" || '';
1378   $autodelete = readlink "$file/autodelete"
1379              || readlink "$to/\@AUTODELETE"
1380              || $::autodelete;
1381   $keep = readlink "$file/keep"
1382        || readlink "$to/\@KEEP"
1383        || $keep_default;
1384
1385   $locale = readlink "$to/\@LOCALE" || readlink "$file/locale" || 'english';
1386   $_ = untaint("$FEXHOME/locale/$locale/lib/lf.pl");
1387   require if -f;
1388   unless ($notify{$locale}) {
1389     $locale = 'english';
1390     $notify{$locale} ||= \&notify;
1391   }
1392   return &{$notify{$locale}}(
1393     status     => $status,
1394     dkey       => $dkey,
1395     filename   => $filename,
1396     keep       => $keep-int((time-$mtime)/$DS),
1397     comment    => $comment,
1398     autodelete => $autodelete,
1399     replyto    => $replyto,
1400   );
1401 }
1402
1403 ########################### locale functions ###########################
1404 # Will be extracted by install process and saved in $FEXHOME/lib/lf.pl #
1405 # You cannot modify them here without re-installing!                   #
1406 ########################################################################
1407
1408 # locale function!
1409 sub notify {
1410   # my ($status,$dkey,$filename,$keep,$warn,$comment,$autodelete) = @_;
1411   my %P = @_;
1412   my ($to,$from,$file,$mimefilename,$receiver,$warn,$comment,$autodelete);
1413   my ($size,$bytes,$days,$header,$data,$replyto,$uurl);
1414   my ($mfrom,$mto,$dfrom,$dto);
1415   my $proto = 'http';
1416   my $durl = $::durl;
1417   my $index;
1418   my $fileid = 0;
1419   my $fua = $ENV{HTTP_USER_AGENT}||'';
1420   my $warning = '';
1421   my $disclaimer = '';
1422   my $download = '';
1423   my $keyring;
1424   my $boundary = randstring(16);
1425   my ($body,$enc_body);
1426
1427   return if $nomail;
1428
1429   $warn = $P{warn}||2;
1430   $comment = $P{comment}||'';
1431   $comment = encode_utf8($P{comment}||'') if utf8::is_utf8($comment);
1432   $comment =~ s/^!\*!//; # multi download allow flag
1433   $autodelete = $P{autodelete}||$::autodelete;
1434
1435   $file = untaint(readlink("$dkeydir/$P{dkey}"));
1436   $file =~ s/^\.\.\///;
1437   # make download protocal same as upload protocol
1438   if ($uurl = readlink("$file/uurl") and $uurl =~ /^(\w+):/) {
1439     $proto = $1;
1440     $durl =~ s/^\w+::/$proto::/;
1441   }
1442   $index = "$proto://$hostname/index.html";
1443   ($to,$from,$file) = split('/',$file);
1444   $filename = strip_path($P{filename});
1445   $mfrom = $from;
1446   $mto = $to;
1447   $mfrom .= '@'.$mdomain if $mdomain and $mfrom !~ /@/;
1448   $mto .=   '@'.$mdomain if $mdomain and $mto   !~ /@/;
1449   $keyring = $to.'/@GPG';
1450   # $to = '' if $to eq $from; # ???
1451   $replyto = $P{replyto}||$mfrom;
1452   $header = "From: <$mfrom> ($mfrom via F*EX service $hostname)\n";
1453   $header .= "Reply-To: <$replyto>\n" if $replyto ne $mfrom;
1454   $header .= "To: <$mto>\n";
1455   $data = "$dkeydir/$P{dkey}/data";
1456   $size = $bytes = -s $data;
1457   return unless $size;
1458   $warning =
1459     "We recommend fexget or fexit for download,\n".
1460     "because these clients can resume the download after an interruption.\n".
1461     "See $proto://$hostname/tools.html";
1462   # if ($nowarning) {
1463   #   $warning = '';
1464   # } else {
1465   #   $warning =
1466   #     "Please avoid download with Internet Explorer, ".
1467   #     "because it has too many bugs.\n\n";
1468   # }
1469   if ($filename =~ /\.(tar|zip|7z|arj|rar)$/) {
1470     $warning .= "\n\n".
1471       "$filename is a container file.\n".
1472       "You can unpack it for example with 7zip ".
1473       "(http://www.7-zip.org/download.html)";
1474   }
1475   if ($limited_download =~ /^y/i) {
1476     $warning .= "\n\n".
1477       'This download link only works for you, you cannot distribute it.';
1478   }
1479   if ($size < 2048) {
1480     $size = "$size Bytes";
1481   } elsif ($size/1024 < 2048) {
1482     $size = int($size/1024)." kB";
1483   } else {
1484     $size = int($size/1024/1024)." MB";
1485   }
1486   if ($autodelete eq 'YES') {
1487     $autodelete = "WARNING: After download (or view with a web browser!), "
1488                 . "the file will be deleted!";
1489   } elsif ($autodelete eq 'DELAY') {
1490     $autodelete = "WARNING: When you download the file it will be deleted "
1491                 . "soon afterwards!";
1492   } else {
1493     $autodelete = '';
1494   }
1495
1496   if (-s $keyring) {
1497     $mimefilename = '';
1498   } else {
1499     $mimefilename = $filename;
1500     if ($mimefilename =~ s/([_\?\=\x00-\x1F\x7F-\xFF])/sprintf("=%02X",ord($1))/eog) {
1501       $mimefilename =~ s/ /_/g;
1502       $mimefilename = '=?UTF-8?Q?'.$mimefilename.'?=';
1503     }
1504   }
1505
1506   unless ($fileid = readlink("$dkeydir/$P{dkey}/id")) {
1507     my @s = stat($data);
1508     $fileid =  @s ? $s[1].$s[9] : 0;
1509   }
1510
1511   if ($P{status} eq 'new') {
1512     $days = $P{keep};
1513     $header .= "Subject: F*EX-upload: $mimefilename\n";
1514   } else {
1515     $days = $warn;
1516     $header .= "Subject: reminder F*EX-upload: $mimefilename\n";
1517   }
1518   $header .= "X-FEX-Client-Address: $fra\n" if $fra;
1519   $header .= "X-FEX-Client-Agent: $fua\n"   if $fua;
1520   foreach my $u (@durl?@durl:($durl)) {
1521     my $durl = sprintf("%s/%s/%s",$u,$P{dkey},normalize_filename($filename));
1522     $header .= "X-FEX-URL: $durl\n" unless -s $keyring;
1523     $download .= "$durl\n";
1524   }
1525   $header .=
1526     "X-FEX-Filesize: $bytes\n".
1527     "X-FEX-File-ID: $fileid\n".
1528     "X-FEX-Fexmaster: $ENV{SERVER_ADMIN}\n".
1529     "X-Mailer: F*EX\n".
1530     "MIME-Version: 1.0\n";
1531   if ($comment =~ s/^\[(\@(.*?))\]\s*//) {
1532     $receiver = "group $1";
1533     if ($_ = readlink "$from/\@GROUP/$2" and m:^../../(.+?)/:) {
1534       $receiver .= " (maintainer: $1)";
1535     }
1536   } else {
1537     $receiver = 'you';
1538   }
1539   if ($days == 1) { $days .= " day" }
1540   else            { $days .= " days" }
1541
1542   # explicite sender set in fex.ph?
1543   if ($sender_from) {
1544     map { s/^From: <$mfrom/From: <$sender_from/ } $header;
1545     open $sendmail,'|-',$sendmail,$mto,$bcc
1546       or http_die("cannot start sendmail - $!");
1547   } else {
1548     # for special remote domains do not use same domain in From,
1549     # because remote MTA will probably reject this e-mail
1550     $dfrom = $1 if $mfrom =~ /@(.+)/;
1551     $dto   = $1 if $mto   =~ /@(.+)/;
1552     if ($dfrom and $dto and @remote_domains and
1553         grep {
1554           $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/
1555         } @remote_domains)
1556     {
1557       $header =~ s/(From: <)\Q$mfrom\E(.*?)\n/$1$admin$2\nReply-To: $mfrom\n/;
1558       open $sendmail,'|-',$sendmail,$mto,$bcc
1559         or http_die("cannot start sendmail - $!");
1560     } else {
1561       open $sendmail,'|-',$sendmail,'-f',$mfrom,$mto,$bcc
1562         or http_die("cannot start sendmail - $!");
1563     }
1564   }
1565   $comment = "\n$comment\n" if $comment;
1566   if ($comment =~ s/\n!(shortmail|\.)!\s*//i
1567     or (readlink("$to/\@NOTIFICATION")||'') =~ /short/i
1568   ) {
1569     $body = qqq(qq(
1570       '$comment'
1571       '$download'
1572       '$size'
1573     ));
1574   } else {
1575     $disclaimer = slurp("$from/\@DISCLAIMER") || qqq(qq(
1576       '$warning'
1577       ''
1578       'F*EX is not an archive, it is a transfer system for personal files.'
1579       'For more information see $index'
1580       ''
1581       'Questions? ==> F*EX admin: $admin'
1582     ));
1583     $disclaimer .= "\n$::disclaimer\n" if $::disclaimer;
1584     $body = qqq(qq(
1585       '$comment'
1586       '$from has uploaded the file'
1587       '  "$filename"'
1588       '($size) for $receiver. Use'
1589       ''
1590       '$download'
1591       'to download this file within $days.'
1592       ''
1593       '$autodelete'
1594       ''
1595       '$disclaimer'
1596     ));
1597   }
1598   $body =~ s/\n\n+/\n\n/g;
1599   if (-s $keyring) {
1600     $enc_body = gpg_encrypt($body,$to,$keyring,$from);
1601   }
1602   if ($enc_body) {
1603     # RFC3156
1604     $header .= qqq(qq(
1605       'Content-Type: multipart/encrypted; protocol="application/pgp-encrypted";'
1606       '\tboundary="$boundary"'
1607       'Content-Disposition: inline'
1608     ));
1609     $body = qqq(qq(
1610       '--$boundary'
1611       'Content-Type: application/pgp-encrypted'
1612       'Content-Disposition: attachment'
1613       ''
1614       'Version: 1'
1615       ''
1616       '--$boundary'
1617       'Content-Type: application/octet-stream'
1618       'Content-Disposition: inline; filename="fex.pgp"'
1619       ''
1620       '$enc_body'
1621       '--$boundary--'
1622     ));
1623   } else {
1624     $header .=
1625       "Content-Type: text/plain; charset=UTF-8\n".
1626       "Content-Transfer-Encoding: 8bit\n";
1627   }
1628   print {$sendmail} $header,"\n",$body;
1629   close $sendmail and return $to;
1630   http_die("cannot send notification e-mail (sendmail error $!)");
1631 }
1632
1633
1634 # locale function!
1635 sub reactivation {
1636   my ($expire,$user) = @_;
1637   my $fexsend = "$FEXHOME/bin/fexsend";
1638   my $reactivation = "$FEXLIB/reactivation.txt";
1639
1640   return if $nomail;
1641
1642   if (-x $fexsend) {
1643     if ($locale) {
1644       my $lr = "$FEXHOME/locale/$locale/lib/reactivation.txt";
1645       $reactivation = $lr if -f $lr and -s $lr;
1646     }
1647     $fexsend .= " -M -D -k 30 -C"
1648                ." 'Your F*EX account has been inactive for $expire days,"
1649                ." you must download this file to reactivate it."
1650                ." Otherwise your account will be deleted.'"
1651                ." $reactivation $user";
1652     # on error show STDOUT and STDERR
1653     my $fo = `$fexsend 2>&1`;
1654     warn $fexsend.'\n'.$fo if $?;
1655   } else {
1656     warn "$0: cannot execute $fexsend for reactivation()\n";
1657   }
1658 }
1659
1660 1;