]> git.treefish.org Git - fex.git/blob - lib/fex.pp
bd7ed98b8c1da2fce22eb65ddad6ee44b0da7f0c
[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");
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   if (@_ > 1 and defined fileno $_[0]) { $H = shift }
987   print {$H} qqq(@_);
988 }
989
990
991 # check sender quota
992 sub check_sender_quota {
993   my $sender = shift;
994   my $squota = $sender_quota||0;
995   my $du = 0;
996   my ($file,$size,%file,$data,$upload);
997   local $_;
998   
999   if (open $qf,'<',"$sender/\@QUOTA") {
1000     while (<$qf>) {
1001       s/#.*//;
1002       $squota = $1 if /sender.*?(\d+)/i;
1003     }
1004     close $qf;
1005   }
1006   
1007   foreach $file (glob "*/$sender/*") {
1008     $data = "$file/data";
1009     $upload = "$file/upload";
1010     if (not -l $data and $size = -s $data) {
1011       # count hard links only once (= same inode)
1012       my $i = (stat($data))[1]||0;
1013       unless ($file{$i}) {
1014         $du += $size;
1015         $file{$i} = $i;
1016       }
1017     } elsif (-f $upload) {
1018       # count hard links only once (= same inode)
1019       my $i = (stat($upload))[1]||0;
1020       unless ($file{$i}) {
1021         $size = readlink "$file/size" and $du += $size;
1022         $file{$i} = $i;
1023       }
1024     }
1025   }
1026   
1027   return($squota,int($du/1024/1024));
1028 }
1029
1030
1031 # check recipient quota
1032 sub check_recipient_quota {
1033   my $recipient = shift;
1034   my $rquota = $recipient_quota||0;
1035   my $du = 0;
1036   my ($file,$size);
1037   local $_;
1038   
1039   if (open my $qf,'<',"$recipient/\@QUOTA") {
1040     while (<$qf>) {
1041       s/#.*//;
1042       $rquota = $1 if /recipient.*?(\d+)/i;
1043     }
1044     close $qf;
1045   }
1046   
1047   foreach $file (glob "$recipient/*/*") {
1048     if (-f "$file/upload" and $size = readlink "$file/size") {
1049       $du += $size;
1050     } elsif (not -l "$file/data" and $size = -s "$file/data") {
1051       $du += $size;
1052     }
1053   }
1054   
1055   return($rquota,int($du/1024/1024));
1056 }
1057
1058
1059 sub getline {
1060   my $file = shift;
1061   local $_;
1062   chomp($_ = <$file>||'');
1063   return $_;
1064 }
1065
1066
1067 # (shell) wildcard matching
1068 sub wcmatch {
1069   local $_ = shift;
1070   my $p = quotemeta shift;
1071   
1072   $p =~ s/\\\*/.*/g;
1073   $p =~ s/\\\?/./g;
1074   $p =~ s/\\\[/[/g;
1075   $p =~ s/\\\]/]/g;
1076
1077   return /$p/;
1078 }
1079
1080   
1081 sub logout {
1082   my $logout;
1083   if    ($skey) { $logout = "/fup?logout=skey:$skey" }
1084   elsif ($gkey) { $logout = "/fup?logout=gkey:$gkey" }
1085   elsif ($akey) { $logout = "/fup?logout=akey:$akey" }
1086   else          { $logout = "/fup?logout" }
1087   return qqq(qq(
1088     '<p>'
1089     '<form name="logout" action="$logout">'
1090     '  <input type="submit" name="logout" value="logout">'
1091     '</form>'
1092     '<p>'
1093   ));
1094 }
1095
1096
1097 # print data dump of global or local variables in HTML
1098 # input musst be a string, eg: '%ENV'
1099 sub DD {
1100   my $v = shift; 
1101   local $_;
1102
1103   $n =~ s/.//;
1104   $_ = eval(qq(use Data::Dumper;Data::Dumper->Dump([\\$v])));
1105   s/\$VAR1/$v/;
1106   s/&/&amp;/g;
1107   s/</&lt;/g;
1108   print "<pre>\n$_\n</pre>\n";
1109 }
1110   
1111 # make symlink
1112 sub mksymlink {
1113   my ($file,$link) = @_;
1114   unlink $file;
1115   return symlink untaint($link),$file;
1116 }
1117
1118
1119 # copy file (and modify) or symlink
1120 # returns chomped file contents or link name
1121 # preserves permissions and time stamps
1122 sub copy {
1123   my ($from,$to,$mod) = @_;
1124   my $link;
1125   local $/;
1126   local $_;
1127   
1128   $to .= '/'.basename($from) if -d $to;
1129
1130   if (defined($link = readlink $from)) {
1131     mksymlink($to,$link);
1132     return $link;
1133   } else {
1134     open $from,'<',$from or return;
1135     open $to,'>',$to or return;
1136     $_ = <$from>;
1137     close $from;
1138     eval $mod if $mod;
1139     print {$to} $_;
1140     close $to or http_die("internal error: $to - $!");
1141     if (my @s = stat($from)) { 
1142       chmod $s[2],$to;
1143       utime @s[8,9],$to unless $mod;
1144     }
1145     chomp;
1146     return $_;
1147   }
1148 }
1149
1150
1151 sub slurp {
1152   my $file = shift;
1153   local $_;
1154   local $/;
1155   
1156   if (open $file,$file) {
1157     $_ = <$file>;
1158     close $file;
1159   }
1160
1161   return $_;
1162 }
1163
1164
1165 # read one line from STDIN (net socket) and assign it to $_
1166 # return number of read bytes
1167 # also set global variable $RB (read bytes)
1168 sub nvt_read {
1169   my $len = 0;
1170
1171   if (defined ($_ = <STDIN>)) {
1172     debuglog($_);
1173     $len = length;
1174     $RB += $len;
1175     s/\r?\n//;
1176   }
1177   return $len;
1178 }
1179
1180
1181 # read forward to given pattern
1182 sub nvt_skip_to {
1183   my $pattern = shift;
1184
1185   while (&nvt_read) { return if /$pattern/ }
1186 }
1187
1188
1189 # HTTP GET and POST parameters
1190 # (not used by fup)
1191 # fills global variable %PARAM :
1192 # normal parameter is $PARAM{$parameter}
1193 # file parameter is $PARAM{$parameter}{filename} $PARAM{$parameter}{data}
1194 sub parse_parameters {
1195   my $cl = $ENV{X_CONTENT_LENGTH} || $ENV{CONTENT_LENGTH} || 0;
1196   my $data = '';
1197   my $filename;
1198   local $_;
1199   
1200   if ($cl > 128*$MB) {
1201     http_die("request too large");
1202   }
1203   
1204   foreach (split('&',$ENV{QUERY_STRING})) {
1205     if (/(.+?)=(.*)/) { $PARAM{$1} = $2 }
1206     else              { $PARAM{$_} = $_ }
1207   }
1208   $_ = $ENV{CONTENT_TYPE}||'';
1209   if ($ENV{REQUEST_METHOD} eq 'POST' and /boundary=\"?([\w\-\+\/_]+)/) {
1210     my $boundary = $1;
1211     while ($RB<$cl and &nvt_read) { last if /^--\Q$boundary/ }
1212     # continuation lines are not checked!
1213     while ($RB<$cl and &nvt_read) {
1214       $filename = '';
1215       if (/^Content-Disposition:.*\s*filename="(.+?)"/i) {
1216         $filename = $1;
1217       }
1218       if (/^Content-Disposition:\s*form-data;\s*name="(.+?)"/i) {
1219         my $p = $1;
1220         # skip rest of mime part header
1221         while ($RB<$cl and &nvt_read) { last if /^\s*$/ }
1222         $data = '';
1223         while (<STDIN>) {
1224           if ($p =~ /password/i) {
1225             debuglog('*' x length)
1226           } else {
1227             debuglog($_)
1228           }
1229           $RB += length;
1230           last if /^--\Q$boundary/;
1231           $data .= $_;
1232         }
1233         unless (defined $_) { die "premature end of HTTP POST\n" }
1234         $data =~ s/\r?\n$//;
1235         if ($filename) {
1236           $PARAM{$p}{filename} = $filename;
1237           $PARAM{$p}{data} = $data;
1238         } else {
1239           $PARAM{$p} = $data;
1240         }
1241         last if /^--\Q$boundary--/;
1242       }
1243     }
1244   }
1245 }
1246
1247
1248 # name based virtual host?
1249 sub vhost {
1250   my $hh = shift; # HTTP_HOST
1251   my $vhost;
1252   my $locale = $ENV{LOCALE};
1253
1254   # memorized vhost? (default is in fex.ph)
1255   %vhost = split(':',$ENV{VHOST}) if $ENV{VHOST};
1256     
1257   if (%vhost and $hh and $hh =~ s/^([\w\.-]+).*/$1/) {
1258     if ($vhost = $vhost{$hh} and -f "$vhost/lib/fex.ph") {
1259       $ENV{VHOST} = "$hh:$vhost"; # memorize vhost for next run
1260       $ENV{FEXLIB} = $FEXLIB = "$vhost/lib";
1261       $logdir = $spooldir    = "$vhost/spool";
1262       $docdir                = "$vhost/htdocs";
1263       @logdir = ($logdir);
1264       if ($locale and -e "$vhost/locale/$locale/lib/fex.ph") {
1265         $ENV{FEXLIB} = $FEXLIB = "$vhost/locale/$locale/lib";
1266       }
1267       require "$FEXLIB/fex.ph" or die "$0: cannot load $FEXLIB/fex.ph - $!";
1268       $ENV{SERVER_NAME} = $hostname;
1269       @doc_dirs = ($docdir);
1270       foreach my $ld (glob "$FEXHOME/locale/*/htdocs") {
1271         push @doc_dirs,$ld;
1272       }
1273       return $vhost;
1274     }
1275   }
1276 }
1277
1278
1279 sub gpg_encrypt {
1280   my ($plain,$to,$keyring,$from) = @_;
1281   my ($pid,$pi,$po,$pe,$enc,$err);
1282   local $_;
1283   
1284   $pe = gensym;
1285   
1286   $pid = open3($po,$pi,$pe,
1287     "gpg --batch --trust-model always --keyring $keyring".
1288     "    -a -e -r $bcc -r $to"
1289   ) or return;
1290   
1291   print {$po} $plain;
1292   close $po;
1293     
1294   $enc .= $_ while <$pi>;
1295   $err .= $_ while <$pe>;
1296   errorlog("($from --> $to) $err") if $err;
1297   
1298   close $pi;
1299   close $pe;
1300   waitpid($pid,0);
1301   
1302   return $enc;
1303 }
1304
1305
1306 sub mtime {
1307   my @s = stat(shift) or return;
1308   return $s[9];
1309 }
1310
1311
1312 # wildcard * to perl regexp
1313 sub quotewild {
1314   local $_ = quotemeta shift;
1315   s/\\\*/.*/g; # allow wildcard *
1316   return $_;
1317 }
1318
1319
1320 # extract locale functions into hash of subroutine references
1321 # e.g. \&german ==> $notify{german}
1322 sub locale_functions {
1323   my $locale = shift;
1324   local $/;
1325   local $_;
1326   
1327   if ($locale and open my $fexpp,"$FEXHOME/locale/$locale/lib/fex.pp") {
1328     $_ = <$fexpp>;
1329     s/.*\n(\#\#\# locale functions)/$1/s;
1330     # sub xx {} ==> xx{$locale} = sub {}
1331     s/\nsub (\w+)/\n\$$1\{$locale\} = sub/gs; 
1332     s/\n}\n/\n};\n/gs;
1333     eval $_;
1334     close $fexpp;
1335   }
1336 }
1337
1338 sub notify_locale {
1339   my $dkey = shift;
1340   my $status = shift || 'new';
1341   my ($to,$keep,$locale,$file,$filename,$comment,$autodelete,$replyto,$mtime);
1342   local $_;
1343
1344   if ($dkey =~ m:/.+/.+/:) {
1345     $file = $dkey;
1346     $dkey = readlink("$file/dkey");
1347   } else {
1348     $file = readlink("$dkeydir/$dkey") 
1349       or http_die("internal error: no DKEY $DKEY");
1350   }
1351   $file =~ s:^../::;
1352   $filename = filename($file);
1353   $to = $file;
1354   $to =~ s:/.*::;
1355   $mtime = mtime("$file/data") or http_die("internal error: no $file/data");
1356   $comment = slurp("$file/comment") || '';
1357   $replyto = readlink "$file/replyto" || '';
1358   $autodelete = readlink "$file/autodelete" 
1359              || readlink "$to/\@AUTODELETE" 
1360              || $::autodelete;
1361   $keep = readlink "$file/keep" 
1362        || readlink "$to/\@KEEP" 
1363        || $keep_default;
1364   
1365   $locale = readlink "$to/\@LOCALE" || readlink "$file/locale" || 'english';
1366   $_ = untaint("$FEXHOME/locale/$locale/lib/lf.pl");
1367   require if -f;
1368   unless ($notify{$locale}) {
1369     $locale = 'english';
1370     $notify{$locale} ||= \&notify;
1371   }
1372   return &{$notify{$locale}}(
1373     status     => $status,
1374     dkey       => $dkey,
1375     filename   => $filename,
1376     keep       => $keep-int((time-$mtime)/$DS),
1377     comment    => $comment,
1378     autodelete => $autodelete,
1379     replyto    => $replyto,
1380   );
1381 }
1382
1383 ########################### locale functions ###########################
1384 # Will be extracted by install process and saved in $FEXHOME/lib/lf.pl #
1385 # You cannot modify them here without re-installing!                   #
1386 ########################################################################
1387
1388 # locale function!
1389 sub notify {
1390   # my ($status,$dkey,$filename,$keep,$warn,$comment,$autodelete) = @_;
1391   my %P = @_;
1392   my ($to,$from,$file,$mimefilename,$receiver,$warn,$comment,$autodelete);
1393   my ($size,$bytes,$days,$header,$data,$replyto,$uurl);
1394   my ($mfrom,$mto,$dfrom,$dto);
1395   my $proto = 'http';
1396   my $durl = $::durl;
1397   my $index;
1398   my $fileid = 0;
1399   my $fua = $ENV{HTTP_USER_AGENT}||'';
1400   my $warning = '';
1401   my $disclaimer = '';
1402   my $download = '';
1403   my $keyring;
1404   my $boundary = randstring(16);
1405   my ($body,$enc_body);
1406
1407   return if $nomail;
1408   
1409   $warn = $P{warn}||2;
1410   $comment = encode_utf8($P{comment}||'');
1411   $comment =~ s/^!\*!//; # multi download allow flag
1412   $autodelete = $P{autodelete}||$::autodelete;
1413   
1414   $file = untaint(readlink("$dkeydir/$P{dkey}"));
1415   $file =~ s/^\.\.\///;
1416   # make download protocal same as upload protocol
1417   if ($uurl = readlink("$file/uurl") and $uurl =~ /^(\w+):/) {
1418     $proto = $1;
1419     $durl =~ s/^\w+::/$proto::/;
1420   }
1421   $index = "$proto://$hostname/index.html";
1422   ($to,$from,$file) = split('/',$file);
1423   $filename = strip_path($P{filename});
1424   $mfrom = $from;
1425   $mto = $to;
1426   $mfrom .= '@'.$mdomain if $mdomain and $mfrom !~ /@/;
1427   $mto .=   '@'.$mdomain if $mdomain and $mto   !~ /@/;
1428   $keyring = $to.'/@GPG';
1429   # $to = '' if $to eq $from; # ???
1430   $replyto = $P{replyto}||$mfrom;
1431   $header = "From: <$mfrom> ($mfrom via F*EX service $hostname)\n";
1432   $header .= "Reply-To: <$replyto>\n" if $replyto ne $mfrom;
1433   $header .= "To: <$mto>\n";
1434   $data = "$dkeydir/$P{dkey}/data";
1435   $size = $bytes = -s $data;
1436   return unless $size;
1437   if ($nowarning) {
1438     $warning = '';
1439   } else {
1440     $warning = 
1441       "Please avoid download with Internet Explorer, ".
1442       "because it has too many bugs.\n".
1443       "We recommend Firefox or wget.";
1444   }
1445   if ($filename =~ /\.(tar|zip|7z|arj|rar)$/) {
1446     $warning .= "\n\n".
1447       "$filename is a container file.\n".
1448       "You can unpack it for example with 7zip ".
1449       "(http://www.7-zip.org/download.html)";
1450   }
1451   if ($limited_download =~ /^y/i) {
1452     $warning .= "\n\n".
1453       'This download link only works for you, you cannot distribute it.';
1454   }
1455   if ($size < 2048) {
1456     $size = "$size Bytes";
1457   } elsif ($size/1024 < 2048) {
1458     $size = int($size/1024)." kB";
1459   } else {
1460     $size = int($size/1024/1024)." MB";
1461   }
1462   if ($autodelete eq 'YES') {
1463     $autodelete = "WARNING: After download (or view with a web browser!), "
1464                 . "the file will be deleted!";
1465   } elsif ($autodelete eq 'DELAY') {
1466     $autodelete = "WARNING: When you download the file it will be deleted "
1467                 . "soon afterwards!";
1468   } else {
1469     $autodelete = '';
1470   }
1471
1472   if (-s $keyring) {
1473     $mimefilename = '';
1474   } else {
1475     $mimefilename = $filename;
1476     if ($mimefilename =~ s/([_\?\=\x00-\x1F\x7F-\xFF])/sprintf("=%02X",ord($1))/eog) {
1477       $mimefilename =~ s/ /_/g;
1478       $mimefilename = '=?UTF-8?Q?'.$mimefilename.'?=';
1479     }
1480   }  
1481   
1482   unless ($fileid = readlink("$dkeydir/$P{dkey}/id")) {
1483     my @s = stat($data);
1484     $fileid =  @s ? $s[1].$s[9] : 0;
1485   }
1486   
1487   if ($P{status} eq 'new') {
1488     $days = $P{keep};
1489     $header .= "Subject: F*EX-upload: $mimefilename\n";
1490   } else {
1491     $days = $warn;
1492     $header .= "Subject: reminder F*EX-upload: $mimefilename\n";
1493   }
1494   $header .= "X-FEX-Client-Address: $fra\n" if $fra;
1495   $header .= "X-FEX-Client-Agent: $fua\n"   if $fua;
1496   foreach my $u (@durl?@durl:($durl)) {
1497     my $durl = sprintf("%s/%s/%s",$u,$P{dkey},normalize_filename($filename));
1498     $header .= "X-FEX-URL: $durl\n" unless -s $keyring;
1499     $download .= "$durl\n";
1500   }
1501   $header .= 
1502     "X-FEX-Filesize: $bytes\n".
1503     "X-FEX-File-ID: $fileid\n".
1504     "X-FEX-Fexmaster: $ENV{SERVER_ADMIN}\n".
1505     "X-Mailer: F*EX\n".
1506     "MIME-Version: 1.0\n";
1507   if ($comment =~ s/^\[(\@(.*?))\]\s*//) { 
1508     $receiver = "group $1";
1509     if ($_ = readlink "$from/\@GROUP/$2" and m:^../../(.+?)/:) {
1510       $receiver .= " (maintainer: $1)";
1511     }
1512   } else { 
1513     $receiver = 'you';
1514   }
1515   if ($days == 1) { $days .= " day" }
1516   else            { $days .= " days" }
1517   
1518   # explicite sender set in fex.ph?
1519   if ($sender_from) {
1520     map { s/^From: <$mfrom/From: <$sender_from/ } $header;
1521     open $sendmail,'|-',$sendmail,$mto,$bcc
1522       or http_die("cannot start sendmail - $!");
1523   } else {
1524     # for special remote domains do not use same domain in From, 
1525     # because remote MTA will probably reject this e-mail
1526     $dfrom = $1 if $mfrom =~ /@(.+)/;
1527     $dto   = $1 if $mto   =~ /@(.+)/;
1528     if ($dfrom and $dto and @remote_domains and 
1529         grep { 
1530           $dfrom =~ /(^|\.)$_$/ and $dto =~ /(^|\.)$_$/ 
1531         } @remote_domains) 
1532     {
1533       $header =~ s/(From: <)\Q$mfrom\E(.*?)\n/$1$admin$2\nReply-To: $mfrom\n/;
1534       open $sendmail,'|-',$sendmail,$mto,$bcc
1535         or http_die("cannot start sendmail - $!");
1536     } else {
1537       open $sendmail,'|-',$sendmail,'-f',$mfrom,$mto,$bcc
1538         or http_die("cannot start sendmail - $!");
1539     }
1540   }
1541   if ($comment =~ s/^!(shortmail|\.)!\s*//i 
1542     or (readlink "$to/\@NOTIFICATION"||'') =~ /short/i
1543   ) {
1544     $body = qqq(qq(
1545       '$comment'
1546       ''
1547       '$download'
1548       '$size'
1549     ));
1550   } else {
1551     $comment = "Comment: $comment\n" if $comment;
1552     $disclaimer = slurp("$from/\@DISCLAIMER") || qqq(qq(
1553       '$warning'
1554       ''
1555       'F*EX is not an archive, it is a transfer system for personal files.'
1556       'For more information see $index'
1557       ''
1558       'Questions? ==> F*EX admin: $admin'
1559     ));
1560     $disclaimer .= "\n" . $::disclaimer if $::disclaimer;
1561     $body = qqq(qq(
1562       '$from has uploaded the file'
1563       '  "$filename"'
1564       '($size) for $receiver. Use'
1565       ''
1566       '$download'
1567       'to download this file within $days.'
1568       ''
1569       '$comment'
1570       '$autodelete'
1571       ''
1572       '$disclaimer'
1573     ));
1574   }
1575   $body =~ s/\n\n+/\n\n/g;
1576   if (-s $keyring) {
1577     $enc_body = gpg_encrypt($body,$to,$keyring,$from);
1578   }
1579   if ($enc_body) {
1580     # RFC3156
1581     $header .= qqq(qq(
1582       'Content-Type: multipart/encrypted; protocol="application/pgp-encrypted";'
1583       '\tboundary="$boundary"'
1584       'Content-Disposition: inline'
1585     ));
1586     $body = qqq(qq(
1587       '--$boundary'
1588       'Content-Type: application/pgp-encrypted'
1589       'Content-Disposition: attachment'
1590       ''
1591       'Version: 1'
1592       ''
1593       '--$boundary'
1594       'Content-Type: application/octet-stream'
1595       'Content-Disposition: inline; filename="fex.pgp"'
1596       ''
1597       '$enc_body'
1598       '--$boundary--'
1599     ));
1600   } else {
1601     $header .=
1602       "Content-Type: text/plain; charset=UTF-8\n".
1603       "Content-Transfer-Encoding: 8bit\n";
1604   }
1605   print {$sendmail} $header,"\n",$body;
1606   close $sendmail and return $to;
1607   http_die("cannot send notification e-mail (sendmail error $!)");
1608 }
1609
1610
1611 # locale function!
1612 sub reactivation {
1613   my ($expire,$user) = @_;
1614   my $fexsend = "$FEXHOME/bin/fexsend";
1615
1616   return if $nomail;
1617   
1618   if (-x $fexsend) {
1619     $fexsend .= " -M -D -k 30 -C"
1620                ." 'Your F*EX account has been inactive for $expire days,"
1621                ." you must download this file to reactivate it."
1622                ." Otherwise your account will be deleted.'"
1623                ." $FEXLIB/reactivation.txt $user";
1624     # on error show STDOUT and STDERR
1625     system "$fexsend >/dev/null 2>&1";
1626     if ($?) {
1627       warn "$fexsend\n";
1628       system $fexsend;
1629     }
1630   } else {
1631     warn "$0: cannot execute $fexsend for reactivation()\n";
1632   }
1633 }
1634
1635 1;