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