#!/usr/bin/perl -Tw # F*EX CGI for administration # # Original author: Andre Hafner <andrehafner@gmx.net> # BEGIN { ($ENV{PERLINIT}||'') =~ /(.+)/s and eval $1 } $| = 1; $fac = $0; $fac =~ s:.*/::; # add fex lib (our $FEXLIB) = $ENV{FEXLIB} =~ /(.+)/ or die "no \$FEXLIB\n"; # import from fex.pp and fex.ph our ($FEXHOME,$spooldir,$logdir,$docdir,$akeydir,$durl,$mdomain,$bs,$hostname); our ($keep_default,$keep_max,$recipient_quota,$sender_quota,$autodelete); our ($admin,$admin_pw,$admin_hosts); our ($sendmail,$bcc); our $error = 'FAC error'; # load common code, local config : $HOME/lib/fex.ph require "$FEXLIB/fex.pp"; my @http_auth = (); my $ra = $ENV{REMOTE_ADDR}||0; if (not @admin_hosts or not ipin($ra,@admin_hosts)) { html_error($error,"Administration from your host ($ra) is not allowed."); } html_error($error,"\$admin not configured in $FEXLIB/fex.ph\n") unless $admin; chdir $spooldir or http_die("$spooldir - $!"); chomp($admin_pw = slurp("$admin/@")||''); html_error($error,"no F*EX account for admin $admin\n") unless $admin_pw; # redirect to https if configured (undef,$port) = split(':',$ENV{HTTP_HOST}||''); $port ||= $ENV{PROTO} eq 'https' ? 443 : 80; if ($port == 80 and open my $x,'/etc/xinetd.d/fexs') { while (<$x>) { if (/^\s*disable\s*=\s*no/) { nvt_print( "HTTP/1.1 301 Moved Permanently", "Location: https://$hostname$ENV{REQUEST_URI}", 'Content-Length: 0', '' ); exit; } } close $x; } our %PARAM; &parse_parameters; $action = $PARAM{"action"}||''; # authentication &require_akey; my $fup = $durl; $fup =~ s:/fop:/fup:; my $http_client = $ENV{HTTP_USER_AGENT} || ''; # files to save with backup function my @backup_files = qw( htdocs/index.html lib/fex.ph lib/fup.pl spool/*@*/@* spool/*@*/.auto ); # backup goes first if ($action eq "backup") { &backup; exit; } http_header('200 OK'); $_ = html_header("F*EX Admin Control for $hostname"); s:</h1>: (<a href="?action=logout">logout</a>)</h1>:; print; my $nav_user = "<li><a href=\"?action=create\">Create new user</a>\n". "<li><a href=\"?action=change-auth\">Change user auth-ID</a>\n". "<li><a href=\"?action=edit\">Edit user restrictions file</a>\n". "<li><a href=\"?action=delete\">Delete existing user</a>\n". "<li><a href=\"?action=quota\">Manage disk quota</a>\n"; my $nav_log = "<li><a href=\"?action=fup.log\">Get fup.log</a>\n". "<li><a href=\"?action=fop.log\">Get fop.log</a>\n". "<li><a href=\"?action=error.log\">Get error.log</a>\n"; if (-f "$logdir/fexsrv.log") { $nav_log = "<li><a href=\"?action=watch\">Watch logfile</a>\n". "<li><a href=\"?action=fexsrv.log\">Get fexsrv.log</a>\n". $nav_log; } my $nav_backup = "<li><a href=\"?action=backup\">Download backup<br>(config only)</a>\n". "<li><a href=\"?action=restore\">Restore backup</a>\n"; my $nav_show = "<li><a href=\"?action=list\">List spooled files</a>\n". "<li><a href=\"?action=showquota\">Show quotas (sender/recipient)</a>\n". "<li><a href=\"?action=showconfig\">Show server config</a>\n". "<li><a href=\"?action=userconfig\">Show user config</a>\n"; my $nav_edit = "<li><a href=\"?action=editconfig\">Edit config</a>\n". "<li><a href=\"?action=editindex\">Edit index.html</a>\n"; pq(qq( '<table border="0">' ' <th>manage user</th>' ' <th>show</th>' ' <th>log files</th>' ' <th>edit</th>' ' <th>backup</th>' ' <tr valign="top">' ' <td><ul>$nav_user</ul>' ' <td><ul>$nav_show</ul>' ' <td><ul>$nav_log</ul>' ' <td><ul>$nav_edit</ul>' ' <td><ul>$nav_backup</ul>' ' </tr>' '</table>' '<hr>' )); my @user_items = &userList; if ($action eq "create") { &createUserForm } elsif ($action eq "change-auth") { &changeAuthForm } elsif ($action eq "edit") { &editRestrictionsForm } elsif ($action eq "delete") { &deleteUserForm } elsif ($action eq "quota") { &changeQuotaForm } elsif ($action eq "list") { &listFiles } elsif ($action eq "showquota") { &showQuota } elsif ($action eq "showconfig") { &showConfig } elsif ($action eq "userconfig") { &userConfigForm } elsif ($action eq "watch") { &watchLog } elsif ($action eq "fexsrv.log") { &getlog("fexsrv.log") } elsif ($action eq "fup.log") { &getlog("fup.log") } elsif ($action eq "fop.log") { &getlog("fop.log") } elsif ($action eq "error.log") { &getlog("error.log") } elsif ($action eq "editconfig") { &editFile("$FEXLIB/fex.ph") } elsif ($action eq "editindex") { &editFile("$docdir/index.html") } elsif ($action eq "backup") { &backup } elsif ($action eq "restore") { &restoreForm } if (defined $PARAM{"createUser"}) { createUser($PARAM{"createUser"}, $PARAM{"authID"}); } elsif (defined $PARAM{"changeAuthUser"}) { if ($PARAM{"changeAuthUser"} =~ /^#.*/) { &changeAuthForm; } else { changeUser($PARAM{"changeAuthUser"}, $PARAM{"authID"}); } } elsif (defined $PARAM{"showUserConfig"}) { if ($PARAM{"showUserConfig"} =~ /^#.*/) { &userConfigForm; } else { showUserConfig($PARAM{"showUserConfig"}); } } elsif (defined $PARAM{"deleteUser"}) { if ($PARAM{"deleteUser"} =~ /^#.*/) { &deleteUserForm; } else { deleteUser($PARAM{"deleteUser"}); } } elsif (defined $PARAM{"userQuota"}) { if ($PARAM{"userQuota"} =~ /^#.*/) { &changeQuotaForm; } else { if (defined $PARAM{"default quota"}) { $user = normalize_user($PARAM{"userQuota"}); unlink "$user/\@QUOTA"; print "$user has now default quota:<p>\n"; print "recipient quota: $recipient_quota MB<br>\n"; print "sender quota: $sender_quota MB<br>\n"; &end_html; } else { alterQuota( $PARAM{"userQuota"}, $PARAM{"recipientQuota"}, $PARAM{"senderQuota"} ); } } } elsif (defined $PARAM{"editUser"}) { if ($PARAM{"editUser"} =~ /^#.*/) { &editRestrictionsForm; } else { if (defined $PARAM{"delete file"}) { $user = normalize_user($PARAM{"editUser"}); unlink "$user/\@ALLOWED_RECIPIENTS"; print "upload restrictions for $user have been deleted\n"; &end_html; } else { editUser($PARAM{"editUser"}); } } } elsif ($PARAM{"contentBox"} and $PARAM{"ar"}) { saveFile($PARAM{"contentBox"},$PARAM{"ar"}); } elsif ($PARAM{"upload_archive"}) { restore($PARAM{"upload_archive"}{data}); } &end_html; ####### # declaration of formular functions ####### # formular for creating new users # required arguments: - sub createUserForm { print h3("Create new user"); pq(qq( '<form action="/$fac" method="post" enctype="multipart/form-data">' '<table>' '<tr>' '<td>user</td><td><input type="text" name="createUser" size="80"></td>' '</tr>' '<tr>' '<td>auth-ID:</td><td><input type="text" name="authID" size="16"></td>' '</tr>' '</table>' '<input type="submit" name="create user" value="create user">' '</form>' )); &end_html; } # formular for changing auth-id of an user # required arguments: - sub changeAuthForm { my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items; print h3("change auth-ID"); pq(qq( '<form action="/$fac" method="post" enctype="multipart/form-data">' '<table>' '<tr>' '<td>user:</td><td><select name="changeAuthUser">@option</select></td>' '</tr>' '<tr>' '<td>new auth-ID:</td><td><input type="text" name="authID" size="16"></td>' '</tr>' '</table>' '<input type="submit" name="change" value="change">' '</form>' )); &end_html; } # formular choosing user, whose config files shall be shown # required arguments: - sub userConfigForm { my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items; print h3("Show user config files"); pq(qq( '<form action="/$fac" method="post enctype="multipart/form-data">' '<table>' '<tr>' '<td>user:</td><td><select name="showUserConfig">@option</select></td>' '</tr>' '</table>' '<input type="submit" name="show config files" value="show config files">' '</form>' )); &end_html; } # formular for choosing user, whose restriction file shall be edited # required arguments: - sub editRestrictionsForm { my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items; print h3("Edit user restriction file"); pq(qq( '<form action="/$fac" method="post enctype="multipart/form-data">' '<table>' '<tr>' '<td>user:</td><td><select name="editUser">@option</select></td>' '</tr>' '</table>' '<input type="submit" name="edit file" value="edit file">' '<input type="submit" name="delete file" value="delete file">' '</form>' )); &end_html; } # formular for choosing user, who shall be removed # required arguments: - sub deleteUserForm { my @option = map { "<option value=\"$_\">$_</option>\n" } @user_items; print h3("Delete existing user"); pq(qq( '<form action="/$fac" method="post enctype="multipart/form-data">' '<table>' '<tr>' '<td>user:</td><td><select name="deleteUser">@option</select></td>' '</tr>' '</table>' '<input type="submit" name="delete user" value="delete user">' '</form>' )); &end_html; } # formular for changing an user's quota file # required arguments: - sub changeQuotaForm { my $user; my @option; my $rquota = ''; my $squota = ''; if ($user = $PARAM{"user"}) { $user = normalize_user($user); $rquota = $1 if ($PARAM{"rquota"}||'') =~ /^(\d+)$/; $squota = $1 if ($PARAM{"squota"}||'') =~ /^(\d+)$/; } foreach (@user_items) { if ($user and $user eq $_) { push @option,"<option value=\"$_\" selected>$_</option>\n"; } else { push @option,"<option value=\"$_\">$_</option>\n"; } } print h3("Manage disk quota"); pq(qq( '<form action="/$fac" method="post" enctype="multipart/form-data">' '<table>' '<tr>' '<td>user:</td><td><select name="userQuota">@option</select></td>' '</tr>' '<tr>' '<td>new quota for recipient:</td>' '<td><input type="text" name="recipientQuota" size="12" value=\"$rquota\">' ' MB (optional)</td>' '</tr>' '<tr>' '<td>new quota for sender:</td>' '<td><input type="text" name="senderQuota" size="12" value=\"$squota\">' ' MB (optional)</td>' '</tr>' '</table>' '<input type="submit" name="change quota" value="change quota">' '<input type="submit" name="default quota" value="default quota">' '</form>' )); &end_html; } # formular for choosing backup file to restore # required arguments: - sub restoreForm { print h2("restore config"); pq(qq( 'Specify the backup-archive you want to restore:<br>' '<form action="/$fac" method="post" enctype="multipart/form-data">' '<input type="file" name="upload_archive" size="80"><br>' '<input type="submit" name="restore" value="restore">' '</form>' )); &end_html; } ####### # declaration user functions ####### # function for creating new users # required arguments: username, auth-id sub createUser { my ($user,$id) = @_; my $idf; http_die("not enough arguments in createUser") unless $id; $user = normalize_user($user); unless (-d "$user") { mkdir "$user",0755 or http_die("cannot mkdir $user - $!"); } $idf = "$user/@"; if (-f $idf) { html_error($error,"There is already an user $user!"); } open $idf,'>',$idf or http_die("cannot write $idf - $!"); print {$idf} $id,"\n"; close $idf or http_die("cannot write $idf - $!"); print "<code>\n"; printf "%s?from=%s&ID=%s<br>\n",$fup,$user,$id; printf "%s/%s<p>\n",$fup,b64("from=$user&id=$id"); print "</code>\n"; notifyUser($user,$id); print "An information e-mail to $user has been sent.\n"; &end_html; } # function for changing an user's auth-ID # required arguments: username, auth-id sub changeUser { my ($user,$id) = @_; http_die("not enough arguments in changeUser") unless $id; $id = despace($id); $user = normalize_user($user); my $idf = "$user/@"; print "<code>\n"; print "$idf<p>"; open $idf,'>',$idf or http_die("cannot write $idf - $!"); print {$idf} $id,"\n"; close $idf or http_die("cannot write $idf - $!"); printf "%s?from=%s&ID=%s<br>\n",$fup,$user,$id; printf "%s/%s\n",$fup,b64("from=$user&id=$id"); print "</code><p>\n"; notifyUser($user,$id,"change-auth"); print "An information e-mail to $user has been sent.\n"; &end_html; } # function for showing an user's config files # required arguments: username sub showUserConfig { my $user = shift; http_die("not enough arguments in showUserConfig!") unless $user; $user = normalize_user($user); chdir "$user" or http_die("could not change directory $user - $!"); print h2("Config files of <code>$user</code>"); foreach my $file (glob('.auto @* @GROUP/*')) { if (-f $file and not -l $file and $file !~ /.*~$/) { print h3($file), "\n"; open $file,'<',$file or http_die("cannot open $file - $!"); # print "<table border=1><tr><td>\n"; dumpfile($file); # print "</tr></table>\n"; close $file; } } &end_html; } # function for editing an user's recipient/sender restrictions # required arguments: username sub editUser { my $user = shift; my $content; http_die("not enough arguments in editUser") unless $user; $user = normalize_user($user); http_die("no user $user") unless -d $user; my $ar = "$user/\@ALLOWED_RECIPIENTS"; unless (-f $ar) { open $ar,'>',$ar or http_die("cannot open $ar - $!"); print {$ar}<<'EOD'; # Restrict allowed recipients. Only those listed here are allowed. # Make this file COMPLETLY empty if you want to disable the restriction. # An allowed recipient is an e-mail address, you can use * as wildcard. # Example: *@flupp.org EOD close $ar; } $content = dehtml(slurp($ar)); pq(qq( 'Edit restrictions file for user $user :<br>' '<form action="/$fac" method="post" enctype="multipart/form-data">' '<textarea name="contentBox" rows="10" cols="80">' '$content' '</textarea><br>' '<input type="hidden" name="ar" value="$ar">' '<input type="submit" name="save changes" value="save changes">' '</form>' )); &end_html; } # function for deleting files # required arguments: list of Files sub deleteFiles { http_die("not enough arguments in deleteFiles") unless (my @files = @_); foreach (@files) { if (-e) { if (unlink $_) { print "file has been deleted: $_<br>\n"; } else { print "file could not be deleted: $_ - $!<br>\n"; } } else { print "file does not exists: $_<br>\n"; } } &end_html; } # function for saving a single file # required arguments: content, location sub saveFile { my ($rf,$ar) = @_; my $new; http_die("not enough arguments in saveFile") unless $ar; if ($ar eq 'index.html') { $ar = "$docdir/index.html" } elsif ($ar eq 'fex.ph') { $ar = "$FEXLIB/fex.ph" } elsif ($ar =~ m'^([^/]+/\@ALLOWED_RECIPIENTS)$') { $ar = $1; } else { http_die("unknown file $ar") } $new = $ar.'_new'; if ($ar =~ /fex.ph$/) { open $new,'>',$new or http_die("cannot open ${ar}_new - $!"); print {$new} $rf; close $new or http_die("cannot write $new - $!");; my $status = dehtml(`perl -c $FEXLIB/fex.ph_new 2>&1`); if ($status =~ /syntax OK/ ) { rename $ar,"$ar~"; rename $new,$ar; http_die("cannot write $ar~ - $!") if $?; } else { rename "$ar~",$ar; pq(qq( 'No valid syntax in configuration file:' '<p><pre>$status</pre><p>' '<a href="javascript:history.back()">back</a>' )); &end_html; } } else { system qw'cp -a',$ar,"$ar~"; } open $ar,'>',$ar or http_die("cannot write $ar - $!"); print {$ar} $rf; close $ar or http_die("cannot write $ar - $!");; print "<code>$ar</code> has been saved\n"; &end_html; } # function for deleting existing user # required arguments: username sub deleteUser { my $user = shift; http_die("not enough arguments in deleteUser") unless $user; $user = normalize_user($user); $idf = "$user/\@"; http_die("no such user $user") unless -f $idf; unlink $idf or http_die("cannot remove $idf - $!"); unlink "$user/\@ALLOWED_RECIPIENTS"; unlink "$user/\@SUBUSER"; rmrf("$user/\@GROUP"); print "$user deleted\n"; &end_html; } # function for saving quota information for one single user # required arguments: username, recipient-quota, sender-quota sub alterQuota { my ($user,$rq,$sq) = @_; my ($rquota,$squota); my $qf; $user = normalize_user($user); http_die("$user is not a F*EX user") unless -d $user; $rquota = $squota = ''; $qf = "$user/\@QUOTA"; if (open $qf,$qf) { while (<$qf>) { s/#.*//; $rquota = $1 if /recipient.*?(\d+)/i; $squota = $1 if /sender.*?(\d+)/i; } close $qf; } $rquota = $1 if $rq and $rq =~ /(\d+)/; $squota = $1 if $sq and $sq =~ /(\d+)/; open $qf,'>',$qf or http_die("cannot write $qf - $!"); print {$qf} "recipient:$rquota\n" if $rquota; print {$qf} "sender:$squota\n" if $squota; close $qf or http_die("cannot write $qf - $!"); $rquota = $recipient_quota unless $rquota; $squota = $sender_quota unless $squota; print h3("New quotas for $user"); print "recipient quota: $rquota MB<br>\n"; print "sender quota: $squota MB<br>\n"; &end_html; } # function for listing f*exed files # required arguments: - sub listFiles { print h3("List current files"); my ($file,$dkey); print "<pre>\n"; foreach $recipient (glob "*@*") { next if -l $recipient; foreach $file (glob "$recipient/*/*") { if (-s "$file/data" and $dkey = readlink("$file/dkey") and -l ".dkeys/$dkey") { ($to,$from,$file) = split "/",$file; $file = html_quote($file); print "$from → $to : $durl/$dkey/$file\n"; } } } print "</pre>\n"; &end_html; } # function for watching the fex-logfile # required arguments: - sub watchLog { if (-f "$logdir/fexsrv.log") { print h2("polling fexsrv.log"),"\n"; open my $log,"$FEXHOME/bin/logwatch|" or http_die("cannot run $FEXHOME/bin/logwatch - $!"); dumpfile($log); } else { print h2("no fexsrv.log"); } &end_html; } # function for showing logfiles # required arguments: logfile-name sub getlog { my $log = shift or http_die("not enough arguments in getLog"); print h2("show $log"); if (open $log,"$logdir/$log") { dumpfile($log); close $log; } else { http_die("cannot open $logdir/$log - $!"); } &end_html; } # function for creating a new backup file # required arguments: - sub backup { my @d = localtime time; my $date = sprintf('%d%02d%02d',$d[5]+1900,$d[4]+1,$d[3]); my $backup = "backup/config-$date.tar"; my $http_client = $ENV{HTTP_USER_AGENT} || ''; my $size; my $home = $FEXHOME; $home = $1 if $ENV{VHOST} and $ENV{VHOST} =~ /:(.+)/; chdir $home or http_die("$home - $!"); unless (-d "backup") { mkdir "backup",0700 or http_die("cannot mkdir backup - $!"); } system "tar -cf $backup @backup_files 2>/dev/null"; $size = -s $backup or http_die("backup file empty"); open $backup,'<',$backup or http_die("cannot open $backup - $!"); nvt_print( 'HTTP/1.1 200 OK', "Content-Length: $size", "Content-Type: application/octet-stream; filename=fex-backup-$date.tar", "Content-Disposition: attachment; filename=\"fex-backup-$date.tar\"", "", ); while (read($backup,my $b,$bs)) { print $b or last; } exit; } # function for restoring an old configuration file # required arguments: uploaded archive sub restore { my $archive_file = shift or http_die("not enough arguments in restore!"); my $restore = "backup.tar"; my $home = $FEXHOME; $home = $1 if $ENV{VHOST} and $ENV{VHOST} =~ /:(.+)/; chdir $home or http_die("$home - $!"); mkdir 'backup'; open $restore,'>',$restore or http_die("cannot open $restore - $!"); print {$restore} $archive_file; close $restore or http_die("cannot write $restore - $!"); if (-s $restore) { print "file upload successful<br>\n"; print "saving actual config in $home/backup/config.tar<br>\n"; print "<pre>\n"; system "tar -cf backup/config.tar @backup_files"; print "</pre>\n"; print "starting restore:\n<p>\n"; print "<pre>\n"; system "tar -xvf $restore"; unlink $restore; &end_html; } else { http_die("upload error - no file data received"); } } # function for editing a text-file # required arguments: filepath, filename sub editFile { my $ar = shift; my $file; $file = dehtml(slurp($ar)); $ar =~ s:.*/::; print h2("edit <code>$ar<code>"); pq(qq( '<form action="/$fac" enctype="multipart/form-data" method="post">' '<textarea name="contentBox" rows="26" cols="80">' '$file' '</textarea><br>' '<input type="hidden" name="ar" value="$ar">' '<input type="submit" name="save changes" value="save changes">' '</form>' )); &end_html; } # function for showing all users' quotas # required arguments: - sub showQuota { print h2("Show quotas (domain sorted, values in MB)"); print "<table border=\"1\"><tr>"; foreach (@user_items) { if (/\#\#\#\s(\S+)/) { print "<tr>"; print "<th>\@$1</th>"; print "<th>sender</th>"; print "<th>sender (used)</th>"; print "<th>recipient</th>"; print "<th>recipient (used)</th>"; print "</tr>\n"; # $table = $_; } else { my $rquota = $recipient_quota; my $squota = $sender_quota; my $rquota_used = 0; my $squota_used = 0; my $user = $_; ($squota,$squota_used) = check_sender_quota($user); ($rquota,$rquota_used) = check_recipient_quota($user); my $action = "quota&user=$user&rquota=$rquota&squota=$squota"; s/\@.*//; print "<tr>"; print "<td><a href=\"?action=$action\">$_</a></td>"; print "<td align=\"right\">$squota</td>"; print "<td align=\"right\">$squota_used</td>"; print "<td align=\"right\">$rquota</td>"; print "<td align=\"right\">$rquota_used</td>"; print "</tr>\n"; } } print "</table>\n"; &end_html; } # function for showing fex-server configuration # required arguments: - sub showConfig { print h3("Show config"); print "<table border=\"0\">\n"; printf "<tr><td>spooldir:</td><td>%s</td>\n",$spooldir; printf "<tr><td>logdir:</td><td>%s</td>\n",$logdir; printf "<tr><td>docdir:</td><td>%s</td>\n",$docdir; printf "<tr><td>durl:</td><td>%s</td>\n",$durl; printf "<tr><td>mdomain:</td><td>%s</td>\n",$mdomain||''; printf "<tr><td>autodelete:</td><td>%s</td>\n",$autodelete; printf "<tr><td>keep:</td><td>%s</td>\n",$keep_default; printf "<tr><td>keep_max:</td><td>%s</td>\n",$keep_max; printf "<tr><td>recipient_quota:</td><td>%s</td>\n",$recipient_quota; printf "<tr><td>sender_quota:</td><td>%s</td>\n",$sender_quota; printf "<tr><td>admin:</td><td>%s</td>\n",$admin; print "</table>\n"; &end_html; } # require authentification sub require_akey { my $id; my $rid; if ($action eq 'logout') { if (($ENV{HTTP_COOKIE}||'') =~ /akey=(\w+)/) { unlink "$akeydir/$1"; } nvt_print( "HTTP/1.1 301 Moved Permanently", "Location: /$fac", 'Content-Length: 0', "Set-Cookie: akey=; Max-Age=0; Discard", '' ); &reexec; } $rid = slurp("$admin/@") or html_error($error,"no F*EX account for $admin"); chomp $rid; $id = $PARAM{"id"}; if ($id) { # correct auth-ID? if ($id eq $rid) { $akey = md5_hex("$admin:$rid"); return; } } elsif ($akey) { # correct akey? return if $akey eq md5_hex("$admin:$rid"); } http_header('200 OK'); print html_header("F*EX Admin Control for $hostname"); if ($akey) { pq(qq( '<font color="red"><h3>' ' wrong akey for <code>$admin</code>' '</h3></font>' )); } if ($id and $id ne $rid) { pq(qq( '<font color="red"><h3>' ' wrong auth-ID for <code>$admin</code>' '</h3></font>' )); } pq(qq( '<form action="/$fac" method="post" enctype="multipart/form-data">' ' auth-ID for <code>$admin</code>:' ' <input type="password" name="id" size="16" autocomplete="off">' '</form>' )); &end_html; } # function for checking simple HTTP authentication # (not used any more, replaced with require_akey) sub require_auth { if ($ENV{HTTP_AUTHORIZATION} and $ENV{HTTP_AUTHORIZATION} =~ /Basic\s+(.+)/) { @http_auth = split(':',decode_b64($1)) } if ( @http_auth != 2 or $http_auth[0] !~ /^(fexmaster|admin|\Q$admin\E)$/ or $http_auth[1] ne $admin_pw ) { http_header( '401 Authorization Required', "WWW-Authenticate: Basic realm=$admin F*EX admin authentification", 'Content-Length: 0', ); # control back to fexsrv for further HTTP handling &reexec; } } # function for sending notification mails to an user # required arguments: username, auth-id, message-type sub notifyUser { my ($user,$id,$type) = @_; my $url = $durl; my $message = 'A F*EX account has been created for you. Use'; http_die("not enough arguments in createUser") unless $id; if ($type and $type eq "change-auth") { $message = 'New auth-ID for your F*EX account has been set. Use' } $user = normalize_user($user); open my $mail,'|-',$sendmail,'-f',$admin,$user,$bcc or http_die("cannot start sendmail - $!"); $url =~ s:/fop::; pq($mail,qq( 'From: $admin' 'To: $user' 'Subject: your F*EX account on $hostname' 'X-Mailer: F*EX' '' '$message' '' '$url/fup?from=$user' 'auth-ID: $id' '' 'See $url/index.html for more information about F*EX.' '' 'Questions? ==> F*EX admin: $admin' )); close $mail or http_die("cannot send notification e-mail (sendmail error $!)"); } # sort key is the (inverse) domain # required arguments: list of usernames (e-mail addresses) sub domainsort { # http_die("not enough arguments in domainsort") unless (my @d = @_); my @d = @_; local $_; foreach (@d) { s/\s//g; s/\./,/ while /\..*@/; s/@/@./; $_ = join('.',reverse(split /\./)); } @d = sort { lc $a cmp lc $b } @d; foreach (@d) { $_ = join('.',reverse(split /\./)); s/,/./g; s/@\./@/; } return @d; } # function for creating a sorted list of all users # required arguments: - sub userList { my (@u,@list); my $domain = ''; my $u; foreach $u (glob('*@*')) { next if -l $u; push @u,$u if -f "$u/@"; } foreach (domainsort(@u)) { if (/@(.+)/) { if ($1 ne $domain) { push @list,"### $1 ###"; } push @list,$_; $domain = $1; } } return @list; } sub dumpfile { my $file = shift; print "<pre>\n"; while (<$file>) { print dehtml($_) } print "\n</pre>\n"; } sub h2 { local $_ = shift; chomp; return "<h2>$_</h2>\n"; } sub h3 { local $_ = shift; chomp; return "<h3>$_</h3>\n"; } sub end_html { print "</body></html>\n"; exit; } sub dehtml { local $_ = shift; s/&/&/g; s/</</g; return $_; }