#!/usr/bin/perl -Tw # F*EX CGI for administration # # Original author: Andre Hafner # 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:: (logout):; print; my $nav_user = "
  • Create new user\n". "
  • Change user auth-ID\n". "
  • Edit user restrictions file\n". "
  • Delete existing user\n". "
  • Manage disk quota\n"; my $nav_log = "
  • Get fup.log\n". "
  • Get fop.log\n". "
  • Get error.log\n"; if (-f "$logdir/fexsrv.log") { $nav_log = "
  • Watch logfile\n". "
  • Get fexsrv.log\n". $nav_log; } my $nav_backup = "
  • Download backup
    (config only)
    \n". "
  • Restore backup\n"; my $nav_show = "
  • List spooled files\n". "
  • Show quotas (sender/recipient)\n". "
  • Show server config\n". "
  • Show user config\n"; my $nav_edit = "
  • Edit config\n". "
  • Edit index.html\n"; pq(qq( '' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
    manage usershowlog fileseditbackup
      $nav_user
    ' '
      $nav_show
    ' '
      $nav_log
    ' '
      $nav_edit
    ' '
      $nav_backup
    ' '
    ' '
    ' )); 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:

    \n"; print "recipient quota: $recipient_quota MB
    \n"; print "sender quota: $sender_quota MB
    \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( '

    ' '' '' '' '' '' '' '' '
    user
    auth-ID:
    ' '' '
    ' )); &end_html; } # formular for changing auth-id of an user # required arguments: - sub changeAuthForm { my @option = map { "\n" } @user_items; print h3("change auth-ID"); pq(qq( '
    ' '' '' '' '' '' '' '' '
    user:
    new auth-ID:
    ' '' '
    ' )); &end_html; } # formular choosing user, whose config files shall be shown # required arguments: - sub userConfigForm { my @option = map { "\n" } @user_items; print h3("Show user config files"); pq(qq( '
    ' '' '' '' '' '
    user:
    ' '' '
    ' )); &end_html; } # formular for choosing user, whose restriction file shall be edited # required arguments: - sub editRestrictionsForm { my @option = map { "\n" } @user_items; print h3("Edit user restriction file"); pq(qq( '
    ' '' '' '' '' '
    user:
    ' '' '' '
    ' )); &end_html; } # formular for choosing user, who shall be removed # required arguments: - sub deleteUserForm { my @option = map { "\n" } @user_items; print h3("Delete existing user"); pq(qq( '
    ' '' '' '' '' '
    user:
    ' '' '
    ' )); &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,"\n"; } else { push @option,"\n"; } } print h3("Manage disk quota"); pq(qq( '
    ' '' '' '' '' '' '' '' '' '' '' '' '' '
    user:
    new quota for recipient:' ' MB (optional)
    new quota for sender:' ' MB (optional)
    ' '' '' '
    ' )); &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:
    ' '
    ' '
    ' '' '
    ' )); &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 "\n"; printf "%s?from=%s&ID=%s
    \n",$fup,$user,$id; printf "%s/%s

    \n",$fup,b64("from=$user&id=$id"); print "\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 "\n"; print "$idf

    "; 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
    \n",$fup,$user,$id; printf "%s/%s\n",$fup,b64("from=$user&id=$id"); print "

    \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 $user"); 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 "
    \n"; dumpfile($file); # print "
    \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 :
    ' '

    ' '
    ' '' '' '
    ' )); &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: $_
    \n"; } else { print "file could not be deleted: $_ - $!
    \n"; } } else { print "file does not exists: $_
    \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:' '

    $status

    ' 'back' )); &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 "$ar 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
    \n"; print "sender quota: $squota MB
    \n"; &end_html; } # function for listing f*exed files # required arguments: - sub listFiles { print h3("List current files"); my ($file,$dkey); print "

    \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 "
    \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
    \n"; print "saving actual config in $home/backup/config.tar
    \n"; print "
    \n";
        system "tar -cf backup/config.tar @backup_files";
        print "
    \n"; print "starting restore:\n

    \n"; print "

    \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 $ar");
    
      pq(qq(
        '
    ' '
    ' '' '' '
    ' )); &end_html; } # function for showing all users' quotas # required arguments: - sub showQuota { print h2("Show quotas (domain sorted, values in MB)"); print ""; foreach (@user_items) { if (/\#\#\#\s(\S+)/) { print ""; print ""; print ""; print ""; print ""; print ""; print "\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 ""; print ""; print ""; print ""; print ""; print ""; print "\n"; } } print "
    \@$1sendersender (used)recipientrecipient (used)
    $_$squota$squota_used$rquota$rquota_used
    \n"; &end_html; } # function for showing fex-server configuration # required arguments: - sub showConfig { print h3("Show config"); print "\n"; printf "\n",$spooldir; printf "\n",$logdir; printf "\n",$docdir; printf "\n",$durl; printf "\n",$mdomain||''; printf "\n",$autodelete; printf "\n",$keep_default; printf "\n",$keep_max; printf "\n",$recipient_quota; printf "\n",$sender_quota; printf "\n",$admin; print "
    spooldir:%s
    logdir:%s
    docdir:%s
    durl:%s
    mdomain:%s
    autodelete:%s
    keep:%s
    keep_max:%s
    recipient_quota:%s
    sender_quota:%s
    admin:%s
    \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( '

    ' ' wrong akey for $admin' '

    ' )); } if ($id and $id ne $rid) { pq(qq( '

    ' ' wrong auth-ID for $admin' '

    ' )); } pq(qq( '
    ' ' auth-ID for $admin:' ' ' '
    ' )); &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 "
    \n";
      while (<$file>) { print dehtml($_) }
      print "\n
    \n"; } sub h2 { local $_ = shift; chomp; return "

    $_

    \n"; } sub h3 { local $_ = shift; chomp; return "

    $_

    \n"; } sub end_html { print "\n"; exit; } sub dehtml { local $_ = shift; s/&/&/g; s/