ezmlm-web-archiv/ezmlm-web-3.0/ezmlm-web.cgi

1299 lines
38 KiB
Perl
Executable File

#!/usr/bin/perl
#===========================================================================
# ezmlm-web.cgi - version 2.3 - 10/06/02005
#
# Copyright (C) 1999/2000, Guy Antony Halse, All Rights Reserved.
# Please send bug reports and comments to guy-ezmlm@rucus.ru.ac.za
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are
# met:
#
# Redistributions of source code must retain the above copyright notice,
# this list of conditions and the following disclaimer.
#
# Redistributions in binary form must reproduce the above copyright notice,
# this list of conditions and the following disclaimer in the documentation
# and/or other materials provided with the distribution.
#
# Neither name Guy Antony Halse nor the names of any contributors
# may be used to endorse or promote products derived from this software
# without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
# IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# ==========================================================================
# All user configuration happens in the config file ``ezmlmwebrc''
# POD documentation is at the end of this file
# ==========================================================================
package ezmlm_web;
# Modules to include
use strict;
use Getopt::Std;
use ClearSilver;
use Mail::Ezmlm;
use Mail::Address;
use File::Copy;
use DB_File;
use CGI;
use IO::File;
use POSIX qw(tmpnam);
use Encode qw/ from_to /; # add by ooyama for char convert
# These two are actually included later and are put here so we remember them.
#use File::Find if ($UNSAFE_RM == 1);
#use File::Copy if ($UNSAFE_RM == 0);
my $q = new CGI;
$q->import_names('Q');
use vars qw[$opt_c $opt_d $opt_C];
getopts('cd:C:');
# Suid stuff requires a secure path.
$ENV{'PATH'} = '/bin';
# We run suid so we can't use $ENV{'HOME'} and $ENV{'USER'} to determine the
# user. :( Don't alter this line unless you are _sure_ you have to.
my @tmp = getpwuid($>); use vars qw[$USER]; $USER=$tmp[0];
# use strict is a good thing++
use vars qw[$HOME_DIR]; $HOME_DIR=$tmp[7];
use vars qw[$DEFAULT_OPTIONS $UNSAFE_RM $ALIAS_USER $LIST_DIR];
use vars qw[$QMAIL_BASE $PRETTY_NAMES];
use vars qw[$FILE_UPLOAD $WEBUSERS_FILE $MAIL_DOMAIN $HTML_TITLE];
use vars qw[$HTML_CSS_FILE $TEMPLATE_DIR $LANGUAGE_DIR $HTML_LANGUAGE];
# set default TEXT_ENCODE
use vars qw[$TEXT_ENCODE]; $TEXT_ENCODE='us-ascii'; # by ooyama for multibyte convert support
# pagedata contains the hdf tree for clearsilver
# pagename refers to the template file that should be used
use vars qw[$DEFAULT_HOST];
use vars qw[$pagedata $pagename $error $customError $warning $customWarning $success];
# Get user configuration stuff
if(defined($opt_C)) {
$opt_C =~ /^([-\w.\/]+)$/; # security check by ooyama
require "$1"; # Command Line
} elsif(-e "$HOME_DIR/.ezmlmwebrc") {
require "$HOME_DIR/.ezmlmwebrc"; # User
} elsif(-e "./ezmlmwebrc") {
require "./ezmlmwebrc"; # Install
} elsif(-e "/etc/ezmlm/ezmlmwebrc") {
require "/etc/ezmlm/ezmlmwebrc"; # System
} else {
&fatal_error("Unable to read config file");
}
# Allow suid wrapper to over-ride default list directory ...
if(defined($opt_d)) {
$LIST_DIR = $1 if ($opt_d =~ /^([-\@\w.\/]+)$/);
}
# If WEBUSERS_FILE is not defined in ezmlmwebrc (as before version 2.2), then use former default value for compatibility
if (!defined($WEBUSERS_FILE)) {
$WEBUSERS_FILE = $LIST_DIR . '/webusers'
}
# check optional stylesheet
$HTML_CSS_FILE = '' unless defined($HTML_CSS_FILE);
# check template directory
$TEMPLATE_DIR = 'template' unless defined($TEMPLATE_DIR);
if (defined($MAIL_DOMAIN) && ($MAIL_DOMAIN ne '')) {
$DEFAULT_HOST = $MAIL_DOMAIN;
} else {
# Work out default domain name from qmail (for David Summers)
open (GETHOST, "<$QMAIL_BASE/defaultdomain") || open (GETHOST, "<$QMAIL_BASE/me") || &fatal_error("Unable to read $QMAIL_BASE/me: $!");
chomp($DEFAULT_HOST = <GETHOST>);
close GETHOST;
}
# Untaint form input ...
&untaint;
my $pagedata = load_hdf();
my $action = $q->param('action');
# check permissions
unless (&check_permission_for_action) {
$pagename = 'list_select';
$error = 'Forbidden';
}
# This is where we decide what to do, depending on the form state and the
# users chosen course of action ...
# TODO: unify all these "is list param set?" checks ...
elsif ($action eq '' || $action eq 'list_select') {
# Default action. Present a list of available lists to the user ...
$pagename = 'list_select';
} elsif ($action eq 'subscribers') {
# display list (or part list) subscribers
if (defined($q->param('list'))) {
$pagename = 'subscribers';
} else {
$pagename = 'list_select';
$error = 'ParameterMissing';
}
} elsif ($action eq 'address_del') {
# Delete a subscriber ...
if (defined($q->param('list'))) {
$success = 'DeleteAddress' if (&delete_address());
$pagename = 'subscribers';
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($action eq 'address_add') {
# Add a subscriber ...
# no selected addresses -> no error
if (defined($q->param('list'))) {
$success = 'AddAddress' if (&add_address());
$pagename = 'subscribers';
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($action eq 'list_delete_ask') {
# Confirm list removal
if (defined($q->param('list'))) {
$pagename = 'list_delete';
} else {
$pagename = 'list_select';
$error = 'ParameterMissing';
}
} elsif ($action eq 'list_delete_do') {
# User really wants to delete a list ...
warn "do it";
if (defined($q->param('list'))) {
$success = 'DeleteList' if (&delete_list());
} else {
$error = 'ParameterMissing';
}
$pagename = 'list_select';
} elsif ($action eq 'list_create_ask') {
# User wants to create a list ...
$pagename = 'list_create';
} elsif ($action eq 'list_create_do') {
# create the new list
# Message if list creation is unsuccessful ...
if (&create_list()) {
$success = 'CreateList';
$pagename = 'subscribers';
} else {
$pagename = 'list_create';
}
} elsif (($action eq 'config_ask') || ($action eq 'config_do')) {
# User wants to see/change the configuration ...
my $subset = $q->param('config_subset');
if (defined($q->param('list')) && ($subset ne '')) {
if ($subset =~ m/^RESERVED-([\w_-]*)$/) {
$pagename = $1
} elsif (($subset =~ /^[\w]*$/) && (-e "$TEMPLATE_DIR/config_$subset" . ".cs")) {
$pagename = 'config_' . $subset;
} else {
$pagename = '';
}
if ($pagename ne '') {
$success = 'UpdateConfig' if (($action eq 'config_do') && &update_config());
} else {
$error = 'UnknownConfigPage';
warn "missing config page: $subset";
$pagename = 'list_select';
}
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($action eq 'textfiles') {
# Edit DIR/text ...
if (defined($q->param('list'))) {
$pagename = 'textfiles';
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($action eq 'textfile_edit') {
# edit the content of a text file
if (defined($q->param('list')) && defined($q->param('file'))) {
if (! &check_filename($q->param('file'))) {
$error = 'InvalidFileName';
$pagename = 'textfiles';
} else {
$pagename = 'textfile_edit';
}
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($action eq 'textfile_save') {
# User wants to save a new version of something in DIR/text ...
if (defined($q->param('list')) && defined($q->param('file')) && defined($q->param('content'))) {
if (! &check_filename($q->param('file'))) {
$error = 'InvalidFileName';
$pagename = 'textfiles';
} elsif (&save_text()) {
$pagename = 'textfiles';
$success = 'SaveFile';
} else {
$warning = 'SaveFile';
$pagename = 'textfile_edit';
}
} else {
$error = 'ParameterMissing';
if ($q->param('list')) {
$pagename = 'textfiles';
} else {
$pagename = 'list_select';
}
}
} else {
$pagename = 'list_select';
$error = 'UnknownAction';
}
# read the current state (after the changes are done)
&set_pagedata();
# set default action, if there is no list available and the user is
# allowed to create a new one
if (($action eq '') && (&webauth_create_allowed()) && ($pagedata->getValue('Data.Lists.0','') eq '')) {
$pagename = 'list_create';
}
# Print page and exit :) ...
&output_page;
exit;
# =========================================================================
sub load_hdf {
# initialize the data for clearsilver
my $hdf = ClearSilver::HDF->new();
$hdf->readFile($LANGUAGE_DIR . '/' . $HTML_LANGUAGE . '.hdf');
# TODO: check for existence
&fatal_error("Template dir ($TEMPLATE_DIR) not found!") unless (-e $TEMPLATE_DIR);
$hdf->setValue("TemplateDir", "$TEMPLATE_DIR/");
&fatal_error("Language data dir ($LANGUAGE_DIR) not found!") unless (-e $LANGUAGE_DIR);
$hdf->setValue("LanguageDir", "$LANGUAGE_DIR/");
$hdf->setValue("ScriptName", $ENV{'SCRIPT_NAME'});
$hdf->setValue("Stylesheet", "$HTML_CSS_FILE");
$hdf->setValue("Config.PageTitle", "$HTML_TITLE");
return $hdf;
}
sub output_page {
# Print the page
$pagedata->setValue('Data.Success', "$success") if (defined($success));
$pagedata->setValue('Data.Error', "$error") if (defined($error));
$pagedata->setValue('Data.Warning', "$warning") if (defined($warning));
$pagedata->setValue('Data.CustomError', "$customError") if (defined($customError));
$pagedata->setValue('Data.CustomWarning', "$customWarning") if (defined($customWarning));
$pagedata->setValue('Data.Action', "$pagename");
my $pagefile = $TEMPLATE_DIR . "/main.cs";
&fatal_error("main template ($pagefile) not found!") unless (-e "$pagefile");
&fatal_error("sub template ($TEMPLATE_DIR/$pagename.cs) not found!") unless (-e "$TEMPLATE_DIR/$pagename.cs");
# print http header
print "Content-Type: text/html; charset=utf-8\n\n";
my $cs = ClearSilver::CS->new($pagedata);
$cs->parseFile($pagefile);
print $cs->render();
}
# ---------------------------------------------------------------------------
sub set_pagedata_list_of_lists()
{
my (@files, $i, $num);
# Read the list directory for mailing lists.
return (0==0) unless (opendir DIR, $LIST_DIR);
@files = sort grep !/^\./, readdir DIR;
closedir DIR;
$num = 0;
# Check that they actually are lists and add good ones to pagedata ...
foreach $i (0 .. $#files) {
if ((-e "$LIST_DIR/$files[$i]/lock") && (&webauth($files[$i]))) {
$pagedata->setValue("Data.Lists." . $num, "$files[$i]");
$num++;
}
}
}
# ---------------------------------------------------------------------------
sub set_pagedata()
{
my ($hostname, $username);
# read available list of lists
&set_pagedata_list_of_lists();
# username and hostname
# Work out if this user has a virtual host and set input accordingly ...
if(-e "$QMAIL_BASE/virtualdomains") {
open(VD, "<$QMAIL_BASE/virtualdomains") || warn "Can't read virtual domains file: $!";
while(<VD>) {
last if(($hostname) = /(.+?):$USER/);
}
close VD;
}
if(!defined($hostname)) {
$username = "$USER-" if ($USER ne $ALIAS_USER);
$hostname = $DEFAULT_HOST;
}
$pagedata->setValue("Data.UserName", "$username");
$pagedata->setValue("Data.HostName", "$hostname");
# modules
# TODO: someone should test, if the mysql support works
$pagedata->setValue("Data.Modules.MySQL", ($Mail::Ezmlm::MYSQL_BASE)? 1 : 0);
# permissions
$pagedata->setValue("Data.Permissions.Create", (&webauth_create_allowed)? 1 : 0 );
$pagedata->setValue("Data.Permissions.FileUpload", ($FILE_UPLOAD)? 1 : 0);
# display webuser textfield?
$pagedata->setValue("Data.WebUser.show", (-e "$WEBUSERS_FILE")? 1 : 0);
# default username for webuser file
$pagedata->setValue("Data.WebUser.UserName", $ENV{'REMOTE_USER'}||'ALL');
# list specific configuration
if ($q->param('list') ne '' )
{
&set_pagedata4list(&get_list_part());
} else {
&set_pagedata4options($DEFAULT_OPTIONS);
}
}
# ---------------------------------------------------------------------------
sub set_pagedata4list
{
my $part_type = shift;
my ($list, $listname, $webusers);
my ($i, $item, @files);
my ($address, $addr_name, %pretty);
$listname = $q->param('list');
if (! -e "$LIST_DIR/$listname/lock" ) {
$warning = 'ListDoesNotExist' if ($warning eq '');
return;
}
# Work out the address of this list ...
$list = new Mail::Ezmlm("$LIST_DIR/$listname");
$pagedata->setValue("Data.List.Name", "$listname");
$pagedata->setValue("Data.List.Address", &this_listaddress);
&set_pagedata4part_list($part_type) if ($part_type ne '');
$i = 0;
tie %pretty, "DB_File", "$LIST_DIR/$listname/webnames" if ($PRETTY_NAMES);
foreach $address (sort $list->subscribers($part_type)) {
if ($address ne '') {
$pagedata->setValue("Data.List.Subscribers." . $i . '.address', "$address");
$addr_name = ($PRETTY_NAMES)? $pretty{$address} : '';
$pagedata->setValue("Data.List.Subscribers." . $i . '.name', $addr_name);
}
$i++;
}
untie %pretty if ($PRETTY_NAMES);
$pagedata->setValue("Data.List.hasDenyList", 1) if ($list->isdeny);
$pagedata->setValue("Data.List.hasAllowList", 1) if ($list->isallow);
$pagedata->setValue("Data.List.hasDigestList", 1) if ($list->isdigest);
# Get the contents of some important files
$item = $list->getpart('prefix');
$pagedata->setValue("Data.List.Prefix", "$item");
$item = $list->getpart('headeradd');
$pagedata->setValue("Data.List.HeaderAdd", "$item");
$item = $list->getpart('headerremove');
$pagedata->setValue("Data.List.HeaderRemove", "$item");
$item = $list->getpart('mimeremove');
$pagedata->setValue("Data.List.MimeRemove", "$item");
$item = $list->getpart('mimereject');
$pagedata->setValue("Data.List.MimeReject", "$item");
$item = $list->getpart('text/trailer');
$pagedata->setValue("Data.List.TrailingText", "$item");
# read message size limits
$list->getpart('msgsize') =~ m/^\s*(\d+)\s*:\s*(\d+)\s*$/;
$pagedata->setValue("Data.List.MsgSize.Max", "$1");
$pagedata->setValue("Data.List.MsgSize.Min", "$2");
# TODO: this is definitely ugly - create a new sub!
if(open(WEBUSER, "<$WEBUSERS_FILE")) {
while(<WEBUSER>) {
last if (($webusers) = m{^$listname\s*\:\s*(.+)$});
}
close WEBUSER;
}
# set default if there was no list definition
$webusers ||= $ENV{'REMOTE_USER'} || 'ALL';
$pagedata->setValue("Data.List.WebUsers", "$webusers");
# get the names of the textfiles of this list
{
my($listDir);
$listDir = $LIST_DIR . '/' . $q->param('list');
# Read the list directory for text ...
if (opendir DIR, "$listDir/text") {
@files = grep !/^\./, readdir DIR;
closedir DIR;
$i = 0;
foreach $item (@files) {
$pagedata->setValue("Data.List.Files." . $i, "$item");
$i++;
}
} else {
$warning = 'TextDirAccessDenied' if ($warning eq '')
}
# text file specified?
if (($q->param('file') ne '') && ($q->param('file') =~ m/^[\w-]*$/)) {
my ($content);
$content = $list->getpart("text/" . $q->param('file'));
from_to($content,$TEXT_ENCODE,'utf8'); # by ooyama for multibyte
$pagedata->setValue("Data.List.File.Name", $q->param('file'));
$pagedata->setValue("Data.List.File.Content", "$content");
}
}
&set_pagedata4options($list->getconfig);
}
# ---------------------------------------------------------------------------
sub set_pagedata4options {
my($options) = shift;
my($i, $key, $state, $value, $dir_of_list);
$dir_of_list = $LIST_DIR . '/' . $q->param('list');
$i = 0;
$key = lc(substr($options,$i,1));
# parse the first part of the options string
while ($key =~ m/\w/) {
# scan the first part of the options string for lower case letters
$state = ($options =~ /^\w*$key\w*\s*/);
$pagedata->setValue("Data.List.Options." . $key , ($state)? 1 : 0);
$i++;
$key = lc(substr($options,$i,1));
}
# the options "t", "p" and "x" are only used to create a default value
# they have no meaning, so we should adapt them to reality
$pagedata->setValue("Data.List.Options.t" , 1)
if (-e "$dir_of_list/text/trailer");
$pagedata->setValue("Data.List.Options.f" , 1)
if (-e "$dir_of_list/prefix");
$pagedata->setValue("Data.List.Options.x" , 1)
if ((-e "$dir_of_list/mimeremove") || (-e "$dir_of_list/mimereject"));
for ($i=0; $i<9; $i++) {
unless (($i eq 1) || ($i eq 2)) {
$state = ($options =~ /$i (?:'(.+?)')/);
unless ($state) {
if ($i eq 0) {
$value = 'mainlist@' . $DEFAULT_HOST;
} elsif ($i eq 3) {
$value = 'from_address@domain.org';
} elsif ($i eq 4) {
$value = '-t24 -m30 -k64';
} elsif ($i eq 5) {
$value = 'owner_address@domain.org';
} elsif ($i eq 6) {
$value = 'host:port:user:password:database:table';
} elsif ($i eq 7) {
$value = "$dir_of_list/mod";
} elsif ($i eq 8) {
$value = "$dir_of_list/mod";
}
} else {
# use the configured value (extracted by the pattern matching for 'state')
$value = $1;
}
$pagedata->setValue("Data.List.Settings." . $i . ".value", $value);
$pagedata->setValue("Data.List.Settings." . $i . ".state", $state ? 1 : 0);
}
}
}
# ---------------------------------------------------------------------------
sub check_filename()
{
my $filename = shift;
return ($filename =~ m/[^\w-]/) ? (1==0) : (0==0);
}
# ---------------------------------------------------------------------------
sub get_list_part
# return the name of the part list (deny, allow, mod, digest or '')
{
$q->param('part') =~ m/^(allow|deny|digest|mod)$/;
return $1;
}
# ---------------------------------------------------------------------------
sub delete_list {
# Delete a list ...
# Fixes a bug from the previous version ... when the .qmail file has a
# different name to the list. We use outlocal to handle vhosts ...
my ($list, $listaddress, $listadd);
$list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
if ($listadd = $list->getpart('outlocal')) {
chomp($listadd);
} else {
$listadd = $q->param('list');
}
$listaddress = $1 if ($listadd =~ /-?(\w+)$/);
if ($UNSAFE_RM == 0) {
# This doesn't actually delete anything ... It just moves them so that
# they don't show up. That way they can always be recovered by a helpful
# sysadmin should he/she be in the mood :)
my $SAFE_DIR = "$LIST_DIR/_deleted_lists";
mkdir "$SAFE_DIR", 0700 if (! -e "$SAFE_DIR");
# look for an unused directory name
my $i = 0;
while (-e "$SAFE_DIR/" . $q->param('list') . "-$i") { $i++; }
$SAFE_DIR .= '/' . $q->param('list') . "-$i";
my ($oldfile); $oldfile = "$LIST_DIR/" . $q->param('list');
unless (move($oldfile, $SAFE_DIR)) {
$warning = 'SafeRemoveRenameDirFailed';
return (1==0);
}
unless (opendir(DIR, "$HOME_DIR")) {
$warning = 'DotQmailDirAccessDenied';
return (1==0);
}
# TODO: this could possibly move some qmail files of other lists - improve it!
my @files = map { "$HOME_DIR/$1" if m{^(\.qmail.+)$} } grep { /^\.qmail-$listaddress/ } readdir DIR;
closedir DIR;
foreach (@files) {
unless (move($_, "$SAFE_DIR")) {
$warning = 'SafeRemoveMoveDotQmailFailed';
return (1==0);
}
}
warn "List '$oldfile' moved (deleted)";
} else {
# This, however, does DELETE the list. I don't like the idea, but I was
# asked to include support for it so ...
unless (rmtree("$LIST_DIR/" . $q->param('list'))) {
$warning = 'UnsafeRemoveListDirFailed';
return (1==0);
}
opendir(DIR, "$HOME_DIR") or &fatal_error("Unable to get directory listing: $!");
my @files = map { "$HOME_DIR/$1" if m{^(\.qmail.+)$} } grep { /^\.qmail-$listaddress/ } readdir DIR;
closedir DIR;
if (unlink(@files) <= 0) {
$warning = 'UnsafeRemoveDotQmailFailed';
return (1==0);
}
warn "List '$list->thislist()' deleted";
}
$q->param(-name=>'list', -values=>'');
}
# ------------------------------------------------------------------------
sub untaint {
$DEFAULT_HOST = $1 if $DEFAULT_HOST =~ /^([\w\d\.-]+)$/;
# Go through all the CGI input and make sure it is not tainted. Log any
# tainted data that we come accross ... See the perlsec(1) man page ...
my (@params, $i, $param);
@params = $q->param;
foreach $i (0 .. $#params) {
my(@values);
next if($params[$i] eq 'mailaddressfile');
foreach $param ($q->param($params[$i])) {
next if $param eq '';
if ($param =~ /^([#-\@\w\.\/\[\]\:\n\r\>\< _"']+)$/) {
push @values, $1;
} else {
warn "Tainted input in '$params[$i]': " . $q->param($params[$i]);
}
$q->param(-name=>$params[$i], -values=>\@values);
}
}
# special stuff
# check the list name
if (($q->param('list') =~ /[^\w-]/) && ($q->param('action') !~ /^list_create_(do|ask)$/)) {
$warning = 'InvalidListName' if ($warning eq '');
$q->param(-name=>'list', -values=>'');
}
}
# ------------------------------------------------------------------------
sub check_permission_for_action {
# test if the user is allowed to modify the choosen list or to create an new one
# the user would still be allowed to fill out the create-form (however he got there),
# but the final creation is omitted
my $ret;
if ($action eq 'list_create_ask' || $action eq 'list_create_do') {
$ret = &webauth_create_allowed();
} elsif (defined($q->param('list'))) {
$ret = &webauth($q->param('list'));
} else {
$ret = (0==0);
}
return $ret;
}
# ------------------------------------------------------------------------
sub add_address {
# Add an address to a list ..
my ($address, $list, $part, @addresses, $fail_count);
$list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
$part = &get_list_part();
$fail_count = 0;
if (($q->param('mailaddressfile')) && ($FILE_UPLOAD)) {
# Sanity check
my $fileinfo = $q->uploadInfo($q->param('mailaddressfile'));
my $filetype = $fileinfo->{'Content-Type'};
unless($filetype =~ m{^text/}) {
$warning = 'InvalidFileFormat';
return (1==0);
}
# Handle file uploads of addresses
my($fh) = $q->param('mailaddressfile');
while (<$fh>) {
next if (/^\s*$/ or /^#/); # blank, comments
if ( /(\w[\-\w_\.]*)@(\w[\-\w_\.]+)/ ) {
chomp();
push @addresses, "$_";
} else {
$fail_count++;
}
}
}
# User typed in an address
if ($q->param('mailaddress_add') ne '') {
$address = $q->param('mailaddress_add');
$address .= $DEFAULT_HOST if ($q->param('mailaddress_add') =~ /\@$/);
# untaint
if ($address =~ m/(\w[\-\w_\.]*)@(\w[\-\w_\.]+)/) {
push @addresses, "$address";
} else {
warn "invalid address to add: $address to $part";
$warning = 'AddAddress';
return (1==0);
}
}
my %pretty;
my $add;
tie %pretty, "DB_File", "$LIST_DIR/" . $q->param('list') . "/webnames" if ($PRETTY_NAMES);
foreach $address (@addresses) {
($add) = Mail::Address->parse($address);
if (($add->address() =~ /^\w[\w_-]*\@/) && !($list->issub($add->address(), $part))) {
# it seems, that we cannot trust the return value of "$list->sub"
$list->sub($add->address(), $part);
if(defined($add->name()) && $PRETTY_NAMES) {
$pretty{$add->address()} = $add->name();
}
} else {
$fail_count++;
}
}
untie %pretty if ($PRETTY_NAMES);
if ($fail_count gt 0) {
$warning = 'AddAddress';
return (1==0);
} else {
return (0==0);
}
}
# ------------------------------------------------------------------------
sub delete_address {
# Delete an address from a list ...
my ($list, @address);
$list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
my $part = &get_list_part();
return (1==0) if ($q->param('mailaddress_del') eq '');
@address = $q->param('mailaddress_del');
if ($list->unsub(@address, $part) != 1) {
$warning = 'DeleteAddress';
return (1==0);
}
if($PRETTY_NAMES) {
my(%pretty, $add);
tie %pretty, "DB_File", "$LIST_DIR/" . $q->param('list') . "/webnames";
foreach $add (@address) {
delete $pretty{$add};
}
untie %pretty;
}
}
# ------------------------------------------------------------------------
sub set_pagedata4part_list {
my($part) = @_;
# Deal with list parts ....
my ($i, $list, $listaddress,);
# Work out the address of this list ...
$list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
$listaddress = &this_listaddress();
$pagedata->setValue("Data.List.PartType", "$part");
if($part eq 'mod') {
# do we store things in different directories?
my $config = $list->getconfig;
# empty values represent default settings - everything else is considered as evil :)
my($postpath) = $config =~ m{7\s*'([^']+)'};
my($subpath) = $config =~ m{8\s*'([^']+)'};
my($remotepath) = $config =~ m{9\s*'([^']+)'};
$pagedata->setValue("Data.List.hasPostMod", ($list->ismodpost)? 1 : 0);
$pagedata->setValue("Data.List.PostModPath", "$postpath");
$pagedata->setValue("Data.List.hasSubMod", ($list->ismodsub)? 1 : 0);
$pagedata->setValue("Data.List.SubModPath", "$subpath");
$pagedata->setValue("Data.List.hasRemoteAdmin", ($list->isremote)? 1 : 0);
$pagedata->setValue("Data.List.RemoteAdminPath", "$remotepath");
}
}
# ------------------------------------------------------------------------
sub create_list {
# Create a list according to user selections ...
# Check if the list directory exists and create if necessary ...
unless ((-e $LIST_DIR) || (mkdir $LIST_DIR, 0700)) {
warn "Unable to create directory ($LIST_DIR): $!";
$warning = 'ListDirAccessDenied';
return (1==0);
}
my ($qmail, $listname, $options, $i);
# Some taint checking ...
$qmail = $1 if $q->param('inlocal') =~ /(?:$USER-)?([^\<\>\\\/\s]+)$/;
$listname = $q->param('list');
if ($listname =~ m/[^\w\.-]/) {
$warning = 'InvalidListName';
return (1==0);
}
# Sanity Checks ...
if ($listname eq '') {
$warning = 'EmptyListName';
return (1==0);
}
if (($listname =~ m/^ALL$/i) || ($listname =~ m/^ALLOW_CREATE$/i)) {
$warning = 'ReservedListName';
return (1==0);
}
if ($qmail eq '') {
$warning = 'InvalidLocalPart';
return (1==0);
}
if (-e "$LIST_DIR/$listname/lock") {
$warning = 'ListNameAlreadyExists';
return (1==0);
}
if (-e "$HOME_DIR/.qmail-$qmail") {
$warning = 'ListAddressAlreadyExists';
return (1==0);
}
$options = &extract_options_from_params();
my($list) = new Mail::Ezmlm;
unless ($list->make(-dir=>"$LIST_DIR/$listname",
-qmail=>"$HOME_DIR/.qmail-$qmail",
-name=>$q->param('inlocal'),
-host=>$q->param('inhost'),
-switches=>$options,
-user=>$USER)
) {
# fatal error
$customWarning = $list->errmsg();
return (1==0);
}
# handle MySQL stuff
if(defined($q->param('setting_state_6')) && $options =~ m/-6\s+/) {
$customWarning = $list->errmsg() unless($list->createsql());
}
# no error returned - just a warning
$warning = 'WebUsersUpdate' unless (&update_webusers());
return (0==0);
}
# ------------------------------------------------------------------------
sub extract_options_from_params()
{
# Work out the command line options ...
my ($options, $avail_options, $settings, $avail_settings, $i);
my ($listname, $list, $old_options, $state, $old_key);
# NOTE: we have to define _every_ (even unchanged) setting
# as ezmlm-make removes any undefined value
$listname = $q->param('list');
$list = new Mail::Ezmlm("$LIST_DIR/$listname");
$old_options = $list->getconfig();
################ options ################
$i = 0;
$old_key = substr($old_options,$i,1);
$avail_options = $q->param('options_available');
# parse the first part of the options string
while ($old_key =~ m/\w/) {
# scan the first part of the options string for lower case letters
if ($avail_options =~ m/$old_key/i) {
my $form_var_name = "option_" . lc($old_key);
# this option was visible for the user
if (defined($q->param($form_var_name))) {
$options .= lc($old_key);
} else {
$options .= uc($old_key);
}
} elsif ("cevz" =~ m/$old_key/i) {
# ignore invalid settings (the output of "getconfig" is really weird!)
} else {
# import the previous set option
$options .= $old_key;
}
$i++;
$old_key = substr($old_options,$i,1);
}
############### settings ################
$avail_settings = $q->param('settings_available');
for ($i=0; $i<9; $i++) {
if ($avail_settings =~ m/$i/) {
# this setting was visible for the user
$options .= " -$i '" . $q->param("setting_value_$i") . "'"
if (defined($q->param("setting_state_$i")));
} else {
# import the previous setting
$state = ($old_options =~ /$i (?:'(.+?)')/);
$options .= " -$i '$1'" if ($state);
}
}
return $options;
}
# ------------------------------------------------------------------------
sub update_config {
# Save the new user entered config ...
my ($list, $options, @inlocal, @inhost, $dir_of_list);
my ($old_msgsize);
$list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
$dir_of_list = $LIST_DIR . '/' . $q->param('list');
$options = &extract_options_from_params();
# save the settings, that are generally overwritten by ezmlm-make :(((
# good candidates are: msgsize, inhost, inlocal and outhost
# maybe there are some others?
$old_msgsize = $list->getpart('msgsize');
# Actually update the list ...
unless($list->update($options)) {
$warning = 'UpdateConfig';
return (1==0);
}
# update trailing text
# remove old one if the checkbox was not active
if (defined($q->param('trailing_text'))) {
if (defined($q->param('option_t'))) {
$list->setpart('text/trailer', $q->param('trailing_text'));
} else {
unlink("$dir_of_list/text/trailer");
}
}
# update prefix text
# remove old one if the checkbox was not active
if (defined($q->param('prefix'))) {
if (defined($q->param('option_f'))) {
$list->setpart('prefix', $q->param('prefix'))
} else {
unlink("$dir_of_list/prefix");
}
}
# update mimeremove
# remove old one if the checkbox was not active
if (defined($q->param('mimeremove'))) {
if (defined($q->param('option_x'))) {
$list->setpart('mimeremove', $q->param('mimeremove'))
} else {
unlink("$dir_of_list/mimeremove");
}
}
# update mimereject
# remove old one if the checkbox was not active
if (defined($q->param('mimereject'))) {
if (defined($q->param('option_x'))) {
$list->setpart('mimereject', $q->param('mimereject'))
} else {
unlink("$dir_of_list/mimereject");
}
}
# Update headeradd and headerremove if these options were visible
$list->setpart('headeradd', $q->param('headeradd'))
if (defined($q->param('headeradd')));
$list->setpart('headerremove', $q->param('headerremove'))
if (defined($q->param('headerremove')));
if (defined($q->param('msgsize_max_value')) && defined($q->param('msgsize_min_value'))) {
my ($minsize, $maxsize);
$maxsize = (defined($q->param('msgsize_max_state'))) ?
$q->param('msgsize_max_value') : 0;
$minsize = (defined($q->param('msgsize_min_state'))) ?
$q->param('msgsize_min_value') : 0;
$list->setpart('msgsize', "$maxsize:$minsize");
} else {
# restore the original value, as ezmlm-make always overrides these values :(((
$list->setpart('msgsize', "$old_msgsize");
}
unless (&update_webusers()) {
$warning = 'WebUsersUpdate';
return (1==0);
}
return (0==0);
}
# ------------------------------------------------------------------------
sub update_webusers {
# replace existing webusers-line or add a new one
# return if there is no webusers entry
return (0==0) unless defined($q->param('webusers'));
# Back up web users file
my $temp_file;
my $fh;
# generate a temporary filename (as suggested by the Perl Cookbook)
do { $temp_file = tmpnam() }
until $fh = IO::File->new($temp_file, O_RDWR|O_CREAT|O_EXCL);
close $fh;
unless (open(TMP, ">$temp_file")) {
warn "could not open a temporary file";
return (1==0);;
}
open(WU, "<$WEBUSERS_FILE");
while(<WU>) { print TMP; }
close WU; close TMP;
my $matched = 0;
my $listname = $q->param('list');
my $webusers_filtered = $q->param('webusers');
# remove any insecure characters (e.g. a line break :))
$webusers_filtered =~ s/[^\w_,-]/ /gs;
open(TMP, "<$temp_file");
unless (open(WU, ">$WEBUSERS_FILE")) {
warn "the webusers file ($WEBUSERS_FILE) is not writable";
return (0==1);
}
while(<TMP>) {
if ($_ =~ m/^$listname\s*:/i) {
print WU $listname . ': ' . $webusers_filtered . "\n" if ($matched == 0);
$matched = 1;
} else {
print WU $_;
}
}
# append the line, if there was no matching line found before
print WU $listname . ': ' . $webusers_filtered . "\n" if ($matched == 0);
close TMP; close WU;
unlink "$temp_file";
}
# ------------------------------------------------------------------------
sub this_listaddress {
# Work out the address of this list ... Used often so put in its own subroutine ...
my ($list, $listaddress);
$list = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
chomp($listaddress = $list->getpart('outlocal'));
$listaddress .= '@';
chomp($listaddress .= $list->getpart('outhost'));
return $listaddress;
}
# ------------------------------------------------------------------------
sub save_text {
# Save new text in DIR/text ...
my ($list) = new Mail::Ezmlm("$LIST_DIR/" . $q->param('list'));
my ($content) = $q->param('content');
from_to($content,'utf8',$TEXT_ENCODE); # by ooyama for multibyte
unless ($list->setpart("text/" . $q->param('file'), $content)) {
$warning = 'SaveFile';
return (1==0);
}
}
# ------------------------------------------------------------------------
sub webauth {
my $listname = shift;
# Check if webusers file exists - if not, then access is granted
return (0==0) if (! -e "$WEBUSERS_FILE");
# if there was no user authentication, then everything is allowed
return (0==0) if ($ENV{'REMOTE_USER'} eq '');
# Read authentication level from webusers file. Format of this file is
# somewhat similar to the unix groups file
unless (open (USERS, "<$WEBUSERS_FILE")) {
warn "Unable to read webusers file ($WEBUSERS_FILE): $!";
$warning = 'WebUsersRead';
return (1==0);
}
# TODO: check, why "directly after creating a new list" this does not
# work without the "m" switch for the regexp - very weird!
# the same goes for webauth_create_allowed
# maybe the creating action changed some file access defaults?
while(<USERS>) {
if (/^($listname|ALL):/im) {
# the following line should be synchronized with the webauth_create_allowed sub
if (/^[^:]*:(|.*[\s,])($ENV{'REMOTE_USER'}|ALL)(,|\s|$)/m) {
close USERS;
return (0==0);
}
}
}
close USERS;
return (1==0);
}
# ---------------------------------------------------------------------------
sub webauth_create_allowed {
# Check if we were called with the deprecated argument "-c" (allow to create lists)
return (0==0) if (defined($opt_c));
# if there was no user authentication, then everything is allowed
return (0==0) if ($ENV{'REMOTE_USER'} eq '');
# Check if webusers file exists - if not, then access is granted
return (0==0) if (! -e "$WEBUSERS_FILE");
# Read create-permission from webusers file.
# the special listname "ALLOW_CREATE" controls, who is allowed to do it
unless (open (USERS, "<$WEBUSERS_FILE")) {
warn "Unable to read webusers file ($WEBUSERS_FILE): $!";
$warning = 'WebUsersRead';
return (1==0);
}
while(<USERS>) {
if (/^ALLOW_CREATE:/im) {
# the following line should be synchronized with the webauth sub
if (/[:\s,]($ENV{'REMOTE_USER'}|(ALL))(,|\s|$)/m) {
close USERS;
return (0==0);
}
}
}
close USERS;
return (1==0);
}
# ---------------------------------------------------------------------------
sub rmtree {
# A subroutine to recursively delete a directory (like rm -f).
# Based on the one in the perl cookbook :)
use File::Find qw(finddepth);
File::Find::finddepth sub {
# assume that File::Find::name is secure since it only uses data we pass it
my($name) = $File::Find::name =~ m{^(.+)$};
if (!-l && -d _) {
rmdir($name) or warn "couldn't rmdir $name: $!";
} else {
unlink($name) or warn "couldn't unlink $name: $!";
}
}, @_;
1;
}
# ------------------------------------------------------------------------
sub fatal_error() {
my $text = shift;
print "Content-Type: text/html; charset=utf-8\n\n";
print "<html><head>\n";
print "<title>ezmlm-web</title></head>\n";
print "<body><h1>a fatal error occoured!</h1>\n";
print "<p><strong><big>$text</big></strong></p>\n";
print "<p>check the error log of your web server for details</p>\n";
print "</body></html>\n";
die "$text";
}
# ------------------------------------------------------------------------
# End of ezmlm-web.cgi v2.3
# ------------------------------------------------------------------------
__END__
=head1 NAME
ezmlm-web - A web configuration interface to ezmlm mailing lists
=head1 SYNOPSIS
ezmlm-web [B<-c>] [B<-C> E<lt>F<config file>E<gt>] [B<-d> E<lt>F<list directory>E<gt>]
=head1 DESCRIPTION
=over 4
=item B<-C> Specify an alternate configuration file given as F<config file>
If not specified, ezmlm-web checks first in the users home directory, then in
F</etc/ezmlm> and then the current directory
=item B<-d> Specify an alternate directory where lists live. This is now
depreciated in favour of using a custom ezmlmwebrc, but is left for backward
compatibility.
=back
=head1 SUID WRAPPER
C<#include stdio.h>
C<void main (void) {>
C</* call ezmlm-web */>
C<system("/path/to/ezmlm-web.cgi");>
C<}>
=head1 DOCUMENTATION/CONFIGURATION
Please refer to the example ezmlmwebrc which is well commented, and
to the README file in this distribution.
=head1 FILES
F<~/.ezmlmwebrc>
F</etc/ezmlm/ezmlmwebrc>
F<./ezmlmwebrc>
=head1 AUTHOR
Guy Antony Halse <guy-ezmlm@rucus.ru.ac.za>
Lars Kruse <ezmlm-web@sumpfralle.de>
=head1 BUGS
None known yet. Please report bugs to the author.
=head1 S<SEE ALSO>
ezmlm(5), ezmlm-cgi(1), Mail::Ezmlm(3)
https://systemausfall.org/toolforge/ezmlm-web
http://rucus.ru.ac.za/~guy/ezmlm/
http://www.ezmlm.org/
http://www.qmail.org/