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