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