]> git.treefish.org Git - fex.git/blob - cgi-bin/fac
1470b83c1f266e5eda46726599cafbae56954947
[fex.git] / cgi-bin / fac
1 #!/usr/bin/perl -w
2
3 # F*EX CGI for administration
4 #
5 # Author: Andre Hafner <andrehafner@gmx.net>
6 #
7
8 use CGI                 qw(:standard);
9 use CGI::Carp           qw(fatalsToBrowser);
10
11 $| = 1;
12
13 # add fex lib
14 (our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/;
15 die "no \$FEXLIB\n" unless -d $FEXLIB;
16
17 # import from fex.pp and fex.ph
18 our ($FEXHOME,$spooldir,$logdir,$docdir,$durl,$mdomain);
19 our ($bs,$hostname,$keep_default,$recipient_quota,$sender_quota,$autodelete);
20 our ($admin,$admin_pw,$admin_hosts);
21 our ($sendmail,$bcc);
22 our $error = 'FAC error';
23
24 # load common code, local config : $HOME/lib/fex.ph
25 require "$FEXLIB/fex.pp" or http_die("cannot load $FEXLIB/fex.pp - $!\n");
26
27 my @http_auth = ();
28 my $ra = $ENV{REMOTE_ADDR}||0;
29
30 if (not @admin_hosts or not ipin($ra,@admin_hosts)) {
31   html_error($error,"Administration from your host ($ra) is not allowed.");
32 }
33
34 html_error($error,"\$admin not configured in $FEXLIB/fex.ph\n") unless $admin;
35
36 chdir $spooldir or http_die("$spooldir - $!");
37 chomp($admin_pw = slurp("$admin/@")||'');
38 html_error($error,"no F*EX account for admin $admin\n") unless $admin_pw;
39
40 # redirect to https if configured
41 if (0 and open my $x,'/etc/xinetd.d/fexs') {
42   while (<$x>) {
43     if (/^\s*disable\s*=\s*no/) {
44       nvt_print(
45         "HTTP/1.1 301 Moved Permanently",
46         "Location: https://$hostname$ENV{REQUEST_URI}",
47         'Content-Length: 0',
48         ''
49       );
50       exit;
51     }
52   }
53   close $x;
54 }
55
56 # authentication
57 &require_akey;
58
59 my $fup = $durl;
60 $fup =~ s:/fop:/fup:;
61
62 my $http_client = $ENV{HTTP_USER_AGENT} || '';
63
64 # here is chosen which files to save with backup function
65 my @backup_files = qw(
66   htdocs/index.html
67   lib/fex.ph
68   lib/fup.pl
69   spool/*@*/@*
70 );
71
72 # backup goes first
73 if (defined param("action") and param("action") eq "backup") { &backup }
74
75 http_header('200 OK');
76
77 $_ = html_header("F*EX Admin Control for $hostname");
78 s:</h1>: (<a href="?action=logout">logout</a>)</h1>:;
79 print;
80
81 my $nav_user = 
82   li("<a href=\"?action=create\">Create new user</a>") . "\n" .
83   li("<a href=\"?action=change-auth\">Change user auth-ID</a>") . "\n" .
84   li("<a href=\"?action=edit\">Edit user restrictions file</a>") . "\n" .
85   li("<a href=\"?action=delete\">Delete existing user</a>") . "\n" .
86   li("<a href=\"?action=quota\">Manage disk quota</a>") . "\n";
87
88 my $nav_log = 
89   li("<a href=\"?action=fup.log\">Get fup.log</a>") . "\n" .
90   li("<a href=\"?action=fop.log\">Get fop.log</a>") . "\n" .
91   li("<a href=\"?action=error.log\">Get error.log</a>") . "\n";
92
93 if (-f 'fexsrv.log') {
94   $nav_log =
95     li("<a href=\"?action=watch\">Watch logfile</a>") . "\n" .
96     li("<a href=\"?action=fexsrv.log\">Get fexsrv.log</a>") . "\n" .
97   $nav_log;
98 }
99
100 my $nav_backup = 
101   li("<a href=\"?action=backup\">Download backup<br>(config only)</a>") . "\n" .
102   li("<a href=\"?action=restore\">Restore backup</a>") . "\n";
103
104 my $nav_show =
105   li("<a href=\"?action=list\">List spooled files</a>") . "\n" .
106   li("<a href=\"?action=showquota\">Show quotas (sender/recipient)</a>") . "\n" .
107   li("<a href=\"?action=showconfig\">Show server config</a>") . "\n" .
108   li("<a href=\"?action=userconfig\">Show user config</a>") . "\n";
109   
110 my $nav_edit =  
111   li("<a href=\"?action=editconfig\">Edit config</a>") . "\n" .
112   li("<a href=\"?action=editindex\">Edit index.html</a>") . "\n";
113
114 #print table({-border=>"0"},Tr({-valign=>"top"},[td([ul($nav_user), ul($nav_log), ul($nav_backup), ul($nav_other)])])), "\n";
115 #print "\n", hr, "\n" ;
116 print table({-border=>"0"},
117         th({},["manage user","show","log files","edit","backup"]),
118         Tr({-valign=>"top"},[td([
119                 ul($nav_user),
120                 ul($nav_show),
121                 ul($nav_log),
122                 ul($nav_edit),
123                 ul($nav_backup)
124 ])])), "\n";
125 print "<hr>\n";
126
127 my @user_items = &userList;
128 if (my $action = param("action")) {
129     if    ($action eq "create")      { &createUserForm } 
130     elsif ($action eq "change-auth") { &changeAuthForm } 
131     elsif ($action eq "edit")        { &editRestrictionsForm } 
132     elsif ($action eq "delete")      { &deleteUserForm } 
133     elsif ($action eq "quota")       { &changeQuotaForm } 
134     elsif ($action eq "list")        { &listFiles }
135     elsif ($action eq "showquota")   { &showQuota } 
136     elsif ($action eq "showconfig")  { &showConfig } 
137     elsif ($action eq "userconfig")  { &userConfigForm } 
138     elsif ($action eq "watch")       { &watchLog } 
139     elsif ($action eq "fexsrv.log")  { &getlog("fexsrv.log") } 
140     elsif ($action eq "fup.log")     { &getlog("fup.log") }
141     elsif ($action eq "fop.log")     { &getlog("fop.log") } 
142     elsif ($action eq "error.log")   { &getlog("error.log") } 
143     elsif ($action eq "editconfig")  { &editFile("$FEXLIB/fex.ph") } 
144     elsif ($action eq "editindex")   { &editFile("$docdir/index.html") } 
145     elsif ($action eq "backup")      { &backup } 
146     elsif ($action eq "restore")     { &restoreForm } 
147     else                             { http_die("STOP TRYING TO CHEAT ME!\n") }
148 }
149
150 if (defined param("createUser")) {
151     createUser(param("createUser"), param("authID"));
152
153 } elsif (defined param("changeAuthUser")) {
154     if (param("changeAuthUser") =~ /^#.*/) {
155         &changeAuthForm;
156     } else {
157         changeUser(param("changeAuthUser"), param("authID"));
158     }
159
160 } elsif (defined param("showUserConfig")) {
161     if (param("showUserConfig") =~ /^#.*/) {
162         &userConfigForm;
163     } else {
164         showUserConfig(param("showUserConfig"));
165     }
166
167 } elsif (defined param("deleteUser")) {
168     if (param("deleteUser") =~ /^#.*/) {
169         &deleteUserForm;
170     } else {
171         deleteUser(param("deleteUser"));
172     }
173
174 } elsif (defined param("userQuota")) {
175     if (param("userQuota") =~ /^#.*/) {
176         &changeQuotaForm;
177     } else {
178         if (defined param("remove quota")) {
179             $user = param("userQuota");
180             deleteFiles("$spooldir/$user/\@QUOTA");
181         } else {
182             alterQuota(param("userQuota"), param("recipientQuota"), param("senderQuota"));
183         }
184     }
185
186 } elsif (defined param("editUser")) {
187     if (param("editUser") =~ /^#.*/) {
188         &editRestrictionsForm;
189     } else {
190         if (defined param("delete file")) {
191             $user = param("editUser");
192             deleteFiles("$spooldir/$user/\@ALLOWED_RECIPIENTS");
193         } else {
194             editUser(param("editUser"));
195         }
196     }
197
198 } elsif (defined param("contentBox") && defined param("ar")) {
199     saveFile(param("contentBox"), param("ar"));
200
201 } elsif (defined param("upload_archive")) {
202     restore(param("upload_archive"));
203 }
204
205 print end_html();
206 exit;
207
208
209 #######
210 # declaration of formular functions
211 #######
212
213 # formular for creating new users
214 # required arguments: -
215 sub createUserForm {
216     my $nameRow = "\n" . td(["user:", textfield(-size=>80, -name=>"createUser")]);
217     my $authRow = "\n" . td(["auth-ID:", textfield(-size=>80, -name=>"authID")]);
218     print "\n", h3("Create new user");
219     print "\n", start_form(-name=>"create", -method=>"POST");
220     print "\n", table(Tr([$nameRow, $authRow]));
221     print "\n", submit('create user'), br;
222     print "\n", end_form;
223 }
224
225 # formular for changing auth-id of an user
226 # required arguments: -
227 sub changeAuthForm {
228     my $nameRow = "\n" . td(["user:", popup_menu(-name=>"changeAuthUser", -values=>\@user_items)]);
229     my $authRow = "\n" . td(["new auth-ID:", textfield(-size=>80, -name=>"authID")]);
230     print "\n", h3("change auth-ID");
231     print "\n", start_form(-name=>"change-auth", -method=>"POST");
232     print "\n", table(Tr([$nameRow, $authRow]));
233     print "\n", submit('change'), br;
234     print "\n", end_form;
235 }
236
237 # formular choosing user, whose config files shall be shown
238 # required arguments: -
239 sub userConfigForm {
240     my $nameRow = "\n". td(["user:", popup_menu(-name=>"showUserConfig", -values=>\@user_items)]);
241     print "\n", h3("Show user config files");
242     print "\n", start_form(-name=>"showUserConfig", -method=>"POST");
243     print "\n", table(Tr([$nameRow]));
244     print "\n", submit('show config files'), br;
245     print "\n", end_form;
246 }
247
248 # formular for choosing user, whose restriction file shall be edited
249 # required arguments: -
250 sub editRestrictionsForm {
251     my $nameRow = "\n" . td(["user:", popup_menu(-name=>"editUser", -values=>\@user_items)]);
252     print "\n", h3("Edit user restriction file");
253     print "\n", start_form(-name=>"edit", -method=>"POST");
254     print "\n", table(Tr([$nameRow]));
255     print "\n", submit('edit file');
256     print "\n", submit('delete file'), br;
257     print "\n", end_form;
258 }
259
260 # formular for choosing user, who shall be removed
261 # required arguments: - 
262 sub deleteUserForm {
263     my $nameRow = "\n". td(["user:", popup_menu(-name=>"deleteUser", -values=>\@user_items)]);
264     print "\n", h3("Delete existing user");
265     print "\n", start_form(-name=>"deleteUser", -method=>"POST");
266     print "\n", table(Tr([$nameRow]));
267     print "\n", submit('delete user'), br;
268
269     print "\n", end_form;
270 }
271
272 # formular for changing an user's quota file
273 # required arguments: -
274 sub changeQuotaForm {
275     my ($rquota,$squota) = '';
276     $rquota = param("rquota") if defined param("rquota");
277     $squota = param("squota") if defined param("squota");
278     my $dropdownMenu;
279     if (defined param("user")) {
280         $dropdownMenu = "<select name=\"userQuota\">\n";
281         foreach (@user_items) {
282             if ($_ eq param("user")) {
283                 $dropdownMenu .= "<option value=\"$_\" selected>$_</option>";
284             } else {
285                 $dropdownMenu .= "<option value=\"$_\">$_</option>";
286             }
287         }
288         $dropdownMenu .= "</select>\n";
289     } else {
290         $dropdownMenu = popup_menu(-name=>"userQuota", -values=>\@user_items);
291     }
292     my $nameRow = "\n" . td(["user:", $dropdownMenu]);
293     my $recipientRow = "\n" . td(["new quota for recipient:", textfield(-size=>20, -name=>"recipientQuota", -value=>$rquota). " MB (optional)"]);
294     my $senderRow = "\n" . td (["new quota for sender:", textfield(-size=>20, -name=>"senderQuota", -value=>$squota). " MB (optional)"]);
295     print "\n", h3("Manage disk quota");
296     print "\n", start_form(-name=>"manageQuota", -method=>"POST");
297     print "\n", table(Tr([$nameRow, $recipientRow, $senderRow]));
298     print "\n", submit('change quota');
299     print "\n", submit('remove quota'), br;
300     print "\n", end_form;
301 }
302
303 # formular for choosing backup file to restore
304 # required arguments: -
305 sub restoreForm {
306     print h2("restore config");
307     print "please specify the backup-archive you want to restore:";
308     print "\n", start_form(-name=>"restoreFile", -method=>"POST");
309     print "\n", filefield(-name=>"upload_archive", -size=>"80"), br;
310     print "\n", submit('restore');
311     print "\n", end_form;
312 }
313
314
315 #######
316 # declaration user functions
317 #######
318
319 # function for creating new users
320 # required arguments: username, auth-id
321 sub createUser {
322     my ($user,$id) = @_;
323     my $idf;
324   
325     $id or http_die("not enough arguments in createUser");
326   
327     $user = lc $user;
328     $user =~ s:/::g;
329     $user =~ s:^[.@]+::;
330     $user =~ s:@+$::;
331
332     if ($user !~ /@/) {
333         if ($mdomain) {
334             $user .= '@'.$mdomain;
335         } else {
336             error("Missing domain part in user address");
337         }
338     }
339   
340     unless (-d "$spooldir/$user") {
341         mkdir "$spooldir/$user",0755 
342           or http_die("cannot mkdir $spooldir/$user - $!\n");
343     }
344   
345     $idf = "$spooldir/$user/@";
346
347     if (-f $idf) {
348         error("There is already an user $user!");       
349     }
350   
351     open $idf,'>',$idf or http_die("cannot write $idf - $!\n");
352     print {$idf} $id,"\n";
353     close $idf or http_die("cannot write $idf - $!\n");
354     print "<code>\n";
355     printf "%s?from=%s&ID=%s<br>\n",$fup,$user,$id;
356     printf "%s/%s<p>\n",$fup,b64("from=$user&id=$id");
357     print "</code>\n";
358     notifyUser($user,$id);
359     print "An information e-mail to $user has been sent.\n";
360 }
361
362 # function for changing an user's auth-ID
363 # required arguments: username, auth-id
364 sub changeUser {
365     my ($user,$id) = @_;
366     defined($id) or http_die("not enough arguments in changeUser.\n");
367
368     $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
369     my $idf = "$spooldir/$user/@";
370     print "<code>\n";
371     print "$idf<p>";
372
373     open $idf,'>',$idf or http_die("cannot write $idf - $!\n");
374     print {$idf} $id,"\n";
375     close $idf or http_die("cannot write $idf - $!\n");
376     printf "%s?from=%s&ID=%s<br>\n",$fup,$user,$id;
377     printf "%s/%s\n",$fup,b64("from=$user&id=$id");
378     print "</code><p>\n";
379     notifyUser($user,$id,"change-auth");
380     print "An information e-mail to $user has been sent.\n";
381 }
382
383 # function for showing an user's config files
384 # required arguments: username
385 sub showUserConfig {
386     http_die("not enough arguments in showUserConfig!\n") unless (my $user = $_[0]);
387    
388     chdir "$spooldir/$user" or http_die("could not change directory $spooldir/$user - $!");
389     print h2("Config files of <code>$user</code>");
390
391     foreach my $file (glob('.auto @* @GROUP/*')) {
392         if (-f $file and not -l $file and $file !~ /.*~$/) {
393             print h3($file), "\n";
394             open $file,'<',$file or http_die("cannot open $file - $!");
395             # print "<table border=1><tr><td>\n";
396             dumpfile($file);
397             # print "</tr></table>\n";
398             close $file;
399         }
400     }
401 }
402
403 # function for editing an user's recipient/sender restrictions
404 # required arguments: username
405 sub editUser {
406     http_die("not enough arguments in editUser.\n") unless (my $user = $_[0]);
407     my @content;
408     http_die("no user $user") unless -d "$spooldir/$user";
409     my $ar = "$spooldir/$user/\@ALLOWED_RECIPIENTS";
410     unless (-f $ar) {
411         print "yeah!";
412         open F,">$ar" or http_die("cannot open $ar - $!");
413         print F<<EOD;
414 # Restrict allowed recipients. Only those listed here are allowed.
415 # Make this file COMPLETLY empty if you want to disable the restriction.
416 # An allowed recipient is an e-mail address, you can use * as wildcard.
417 # Example: *\@flupp.org
418 EOD
419         close F;
420     }
421     open my $file,'<',$ar or http_die("cannot open $ar - $!");
422     while (<$file>) {
423         push @content, $_;
424     }
425     close $file or http_die("cannot write $file - $!\n");
426     print "\nedit file:", br;
427     print "\n", start_form(-name=>"editRestrictions", -method=>"POST");
428     print "\n", textarea(-name=>'contentBox', -default=>join('',@content), -rows=>10, -columns=>80), br;
429     print "\n", hidden(-name=>'ar', -default=>"$ar",);
430     print "\n", submit('save changes');
431     print "\n", end_form;
432 }
433
434 # function for deleting files
435 # required arguments: list of Files
436 sub deleteFiles {
437     http_die("not enough arguments in deleteFiles.\n") unless (my @files = @_);
438     
439     foreach (@files) {
440         if (-e $_) {
441             if (unlink $_) {
442                 print "file has been deleted: $_\n", br;
443             } else {
444                 print "file could not be deleted: $_ - $!\n", br;
445             }
446         } else {
447             print "file does not exists: $_\n", br;
448         }
449     }
450 }
451
452 # function for saving a single file
453 # required arguments: content, location
454 sub saveFile {
455     http_die("not enough arguments in saveFile.\n") unless (my ($rf,$ar) = @_);
456
457     if ($ar eq "$FEXLIB/fex.ph") {
458         open my $conf,">${ar}_new" or http_die("cannot open ${ar}_new - $!");
459         print {$conf} $rf;
460         close $conf or http_die("cannot write $conf - $!\n");;
461         my $status = `perl -c $FEXLIB/fex.ph_new 2>&1`;
462         if ($status =~ /syntax OK/ ) {
463              unlink "${ar}_new";
464         } else {
465             pq(qq(
466               'No valid syntax in configuration file:'
467               '<p>'
468               '<pre>$status</pre>'
469             ));
470             &editFile("$FEXLIB/fex.ph_new");
471             exit;
472         }
473     }
474     open my $file,">$ar" or http_die("cannot open $ar - $!");
475     print {$file} $rf;
476     close $file or http_die("cannot write $file - $!\n");;
477     print "The following data has been saved:\n<p>\n";
478     open $file,'<',$ar or http_die("cannot open $ar - $!");
479     if ($ar =~ /\.html$/) {
480         print while <$file>;
481     } else {
482         print "<pre>\n";
483         print while <$file>;
484     }
485     close $file or http_die("cannot write $file - $!\n");;
486 }
487
488 # function for deleting existing user
489 # required arguments: username
490 sub deleteUser {
491     http_die("not enough arguments in createUser.\n") unless (my $user = $_[0]);
492
493     $idf = "$spooldir/$user/\@";
494     http_die("no such user $user\n") unless -f $idf;
495     unlink $idf or http_die("cannot remove $idf - $!\n");
496     unlink "$spooldir/$user/\@ALLOWED_RECIPIENTS";
497     print "$user deleted\n";
498 }
499
500 # function for saving quota information for one single user
501 # required arguments: username, recipient-quota, sender-quota
502 sub alterQuota {
503     http_die("not enough arguments in createUser.\n") unless (my ($user,$rq,$sq) = @_);
504
505     $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
506     unless (-d "$spooldir/$user") {
507         http_die("$user is not a regular F*EX user\n");
508     }
509
510     $rquota = $squota = '';
511     $qf = "$spooldir/$user/\@QUOTA";
512     if (open $qf,'<',$qf) {
513         while (<$qf>) {
514             s/#.*//;
515             $rquota = $1 if /recipient.*?(\d+)/i;
516             $squota = $1 if /sender.*?(\d+)/i;
517         }
518         close $qf or http_die("cannot write $qf - $!\n");
519     }
520
521     open $qf,'>',$qf or http_die("cannot open $qf - $!\n");
522     if(defined($rq) && $rq ne "") {
523         $rquota = $1 if $rq =~ /(\d+)/i;
524     }
525     if(defined($sq) && $sq ne "") {
526         $squota = $1 if $sq =~ /(\d+)/i;
527     }    
528     print {$qf} "recipient:$rquota\n" if $rquota =~ /\d/;
529     print {$qf} "sender:$squota\n" if $squota =~ /\d/;
530     close $qf or http_die("cannot write $qf - $!\n");
531
532     $rquota = $recipient_quota if $rquota !~ /\d/;
533     $squota = $sender_quota    if $squota !~ /\d/;
534     print h3("New quotas for $user");
535     print "recipient quota: $rquota MB\n", br;
536     print "sender quota:   $squota MB\n", br;
537 }
538
539 # function for listing f*exed files
540 # required arguments: -
541 sub listFiles {
542     print h3("List current files"),"\n";
543     my ($file,$dkey);
544     chdir $spooldir or http_die("$spooldir - $!\n");
545     print "<code>\n";
546     foreach $file (glob "*/*/*") {
547         if (-s "$file/data" and  $dkey = readlink("$file/dkey") and -l ".dkeys/$dkey") {
548           ($to,$from,$file) = split "/",$file;
549           $file = html_quote($file);
550           print "$from --> $to : $durl/$dkey/$file<br>\n";
551         }
552     }
553     print "</code>\n";
554 }
555
556 # function for watching the fex-logfile
557 # required arguments: -
558 sub watchLog {
559   if (-f 'fexsrv.log') {
560     print h2("polling fexsrv.log"),"\n";
561     open my $log,"$FEXHOME/bin/logwatch|" 
562       or http_die("cannot run $FEXHOME/bin/logwatch - $!\n");
563     dumpfile($log);
564   } else {
565     print h2("no fexsrv.log"),"\n";
566   }
567 }
568
569 # function for showing logfiles
570 # required arguments: logfile-name
571 sub getlog {
572     my $log = shift or http_die("not enough arguments in getLog");
573
574     print h2("show $log"),"\n";
575     if (open $log,"$logdir/$log") {
576         dumpfile($log);
577         close $log;
578     } else {
579         http_die("cannot open $logdir/$log - $!\n");
580     }
581 }
582
583 # function for creating a new backup file
584 # required arguments: -
585 sub backup {
586     my @d = localtime time;
587     my $date = sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]);
588     my $backup = "backup/config-$date.tar";
589     my $http_client = $ENV{HTTP_USER_AGENT} || '';
590     my $size;
591
592     my $home = $FEXHOME;
593     $home = $1 if $ENV{VHOST} and $ENV{VHOST} =~ /:(.+)/;
594   
595     chdir $home or http_die("$home - $!\n");
596
597     unless (-d "backup") {
598         mkdir "backup",0700 or http_die("cannot mkdir backup - $!\n");
599     }
600
601     system "tar -cf $backup @backup_files 2>/dev/null";
602
603     $size = -s $backup or http_die("backup file empty\n");
604
605     open $backup,'<',$backup or http_die("cannot open $backup - $!\n");
606
607     nvt_print(
608         'HTTP/1.1 200 OK',
609         "Content-Length: $size",
610         "Content-Type: application/octet-stream; filename=fex-backup-$date.tar",
611         "Content-Disposition: attachment; filename=\"fex-backup-$date.tar\"",
612         "",
613         );
614  
615     while (read($backup,my $b,$bs)) {
616         print $b or last;
617     }
618
619     exit;
620 }
621
622 # function for restoring an old configuration file
623 # required arguments: uploaded archive
624 sub restore {
625     http_die("not enough arguments in restore!\n") unless (my $archive_file = $_[0]);
626     my $restore = "backup.tar";
627
628     my $home = $FEXHOME;
629     $home = $1 if $ENV{VHOST} and $ENV{VHOST} =~ /:(.+)/;
630
631     chdir $home or http_die("$home - $!\n");
632
633     open $restore,'>',$restore or http_die("cannot open $restore - $!");
634
635     my $data;
636     while(read $archive_file,$data,$bs) {
637         print {$restore} $data;
638     }
639     close $restore or http_die("cannot write $restore - $!");
640     if (-s $restore) {
641         print "file upload successful, saving actual config in $home/backup/failsave.tar\n", br;
642         system "tar -cf $home/backup/failsave.tar @backup_files 2>/dev/null";
643         print "starting restore:\n<p><pre>\n";
644         system "tar -xvf $restore";
645         unlink $restore;
646     } else {
647         http_die("upload error - no file data received\n");
648     }
649 }
650
651 # function for editing a text-file
652 # required arguments: filepath, filename
653 sub editFile {
654     my $ar = shift;
655     my $file;
656     local $/;
657   
658     open $ar,'<',$ar or http_die("cannot open $ar - $!");
659     $file = <$ar>;
660     close $ar;
661
662     print start_form(-name=>"editFile", -method=>"POST"),"\n";
663     print textarea(-name=>'contentBox', -default=>$file, -rows=>26, -columns=>80), br,"\n";
664     print hidden(-name=>'ar', -default=>"$ar"),"\n";
665     print submit('save changes'),"\n";
666     print end_form(),"\n";
667 }
668
669 # function for showing all users' quotas
670 # required arguments: -
671 sub showQuota {
672     my @table_content;
673     my $table_head;
674
675     print h2("Show quotas (domain sorted, values in MB)");
676     foreach (@user_items) {
677         if (s/###\s*//g) {
678             $table_head = th({}, ["\@$_","sender","sender (used)","recipient","recipient (used)"]);
679             if (@table_content) {
680                 print table({-border=>1},Tr([@table_content])), "\n<p>\n";
681                 @table_content = '';
682             }
683             push @table_content, $table_head;
684         } else {
685             my $rquota = $recipient_quota;
686             my $squota = $sender_quota;
687             my $rquota_used = 0;
688             my $squota_used = 0;
689             my $user = $_;
690             ($squota,$squota_used) = check_sender_quota($user);
691             ($rquota,$rquota_used) = check_recipient_quota($user);
692             s/\@.*//;
693             push @table_content, 
694               "<td><a href=\"?action=quota&user=$user&rquota=$rquota&squota=$squota\">$_</a></td>".
695               "<td align=\"right\">$squota</td>".
696               "<td align=\"right\">$squota_used</td>".
697               "<td align=\"right\">$rquota</td>".
698               "<td align=\"right\">$rquota_used</td>";
699         }
700     }
701     print table({-border=>1},Tr([@table_content])), "\n";
702 }
703
704 # function for showing fex-server configuration
705 # required arguments: -
706 sub showConfig {
707     print h3("Show config");
708     print table({},Tr([
709                     td(["spooldir:",        $spooldir       ]),
710                     td(["logdir:",          $logdir         ]),
711                     td(["docdir:",          $docdir         ]),
712                     td(["durl:",            $durl           ]),
713                     td(["mdomain:",         $mdomain||''    ]),
714                     td(["autodelete:",      $autodelete     ]),
715                     td(["keep:",            $keep_default   ]),
716                     td(["recipient_quota:", $recipient_quota]),
717                     td(["sender_quota:",    $sender_quota   ]),
718                     td(["admin:",           $admin          ])
719     ]));
720 }
721
722 # require authentification
723 sub require_akey {
724   my $id;
725   my $rid;
726   my $action;
727
728   $action = param("action");
729   if ($action and $action eq 'logout') {
730     nvt_print(
731       "HTTP/1.1 301 Moved Permanently",
732       "Location: /fac",
733       'Content-Length: 0',
734       "Set-Cookie: akey=; Max-Age=0; Discard",
735       ''
736     );
737     &reexec;
738   }
739
740   $rid = slurp("$admin/@") or html_error($error,"no F*EX account for $admin");
741   chomp $rid;
742
743   $id = param("id");  
744
745   if ($id) {
746     # correct auth-ID?
747     if ($id eq $rid) {
748       $akey = md5_hex("$admin:$rid");
749       return;
750     }
751   } elsif ($akey) {
752     # correct akey?
753     return if $akey eq md5_hex("$admin:$rid");
754   }  
755
756   http_header('200 OK');
757   print html_header("F*EX Admin Control for $hostname");
758
759   if ($akey) {
760     pq(qq(
761       '<font color="red"><h3>'
762       '  wrong akey for <code>$admin</code>'
763       '</h3></font>'
764     ));
765   }
766
767   if ($id and $id ne $rid) {
768     pq(qq(
769       '<font color="red"><h3>'
770       '  wrong auth-ID for <code>$admin</code>'
771       '</h3></font>'
772     ));
773   }
774
775   pq(qq(
776     '<form action="/fac" '
777     '      method="post" '
778     '      enctype="multipart/form-data">'
779     '  auth-ID for <code>$admin</code>:'
780     '  <input type="password" name="id" size="16" autocomplete="off">'
781     '</form>'
782   ));
783   exit;
784 }
785
786
787 # function for checking simple HTTP authentication
788 # (not used any more, replaced with require_akey)
789 sub require_auth {
790   if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/) 
791   { @http_auth = split(':',decode_b64($1)) }
792   if (
793     @http_auth != 2 
794     or $http_auth[0] !~ /^(fexmaster|admin|\Q$admin\E)$/
795     or $http_auth[1] ne $admin_pw
796   ) {
797     http_header(
798       '401 Authorization Required',
799       "WWW-Authenticate: Basic realm=$admin F*EX admin authentification",
800       'Content-Length: 0',
801     );
802     # control back to fexsrv for further HTTP handling
803     &reexec;
804   }
805 }
806
807 # function for sending notification mails to an user
808 # required arguments: username, auth-id, message-type
809 sub notifyUser {
810     http_die("not enough arguments in createUser.\n") unless (my ($user,$id) = @_);
811     my $type = $_[2];
812     my $message = 'A F*EX account has been created for you. Use';
813
814     if (defined($type) and $type eq "change-auth") {
815         $message = 'New auth-ID for your F*EX account has been set. Use'
816     }
817
818     $user .= '@'.$mdomain if $mdomain and $user !~ /@/;
819     open my $mail,'|-',$sendmail,'-f',$admin,$user,$bcc
820         or http_die("cannot start sendmail - $!\n");
821     pq($mail,qq(
822         'From: $admin'
823         'To: $user'
824         'Subject: your F*EX account on $hostname'
825         'X-Mailer: F*EX'
826         ''
827         '$message'
828         ''
829         '$ENV{PROTO}://$ENV{HTTP_HOST}/fup?from=$user'
830         'auth-ID: $id'
831         ''
832         'See http://$ENV{HTTP_HOST}/index.html for more information about F*EX.'
833         ''
834         'Questions? ==> F*EX admin: $admin'
835     ));
836     close $mail
837         or http_die("cannot send notification e-mail (sendmail error $!)\n");
838 }
839
840 # sort key is the (inverse) domain
841 # required arguments: list of usernames (e-mail addresses)
842 sub domainsort {
843 #    http_die("not enough arguments in domainsort.\n") unless (my @d = @_);
844     my @d = @_;
845     local $_;
846
847     foreach (@d) {
848         s/ //g;
849         s/^/ /;
850         s/\./,/ while /\..*@/;
851         s/@/@./;
852         $_ = join('.',reverse(split /\./));
853     }
854
855     @d = sort { lc $a cmp lc $b } @d;
856
857     foreach (@d) {
858         $_ = join('.',reverse(split /\./));
859         s/,/./g;
860         s/@\./@/;
861     }
862
863     return @d;
864 }
865
866 # function for creating a sorted list of all users
867 # required arguments: -
868 sub userList {
869     my @u;
870     my $d = '';
871
872     foreach (domainsort(grep { s:/@:: } glob('*@*/@'))) {
873         s/ //g;
874         /@(.+)/;
875         if ($1 ne $d) {
876             push @u,"### $1 ###";
877         }
878         push @u,$_;
879         $d = $1;
880     }
881     return @u;
882 }
883
884
885 sub dumpfile {
886   my $file = shift;
887   
888   print "<pre>\n";
889   while (<$file>) {
890     s/&/&amp;/g;
891     s/</&lt;/g;
892     print or exit;
893   }
894   print "\n</pre>\n";
895 }
896
897
898 sub error {
899     print join("\n",@_),"\n";
900     print end_html();
901     exit;
902 }