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