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 }